sdgf

hq-sample.cabal

@@ -16,12 +16,15 @@ extra-source-files:
 
 library
   exposed-modules:
+      API.Server
       Data.Persist.Tap
       Data.Persist.TapTrans
       Data.State.Track
       Data.Types
+      Domain.Sample
       Env.Cache
       Env.Persist.Tap
+      Infrastructure.App
       Infrastructure.Mongo
       Infrastructure.Persist.Tap
       Lib
@@ -62,7 +65,8 @@ library
     , mtl
     , optics
     , resource-pool
-    , spock
+    , servant
+    , servant-server
     , stm
     , text
     , time
@@ -111,7 +115,8 @@ executable hq-sample
     , mtl
     , optics
     , resource-pool
-    , spock
+    , servant
+    , servant-server
     , stm
     , text
     , time
@@ -166,7 +171,8 @@ test-suite hq-sample-test
     , mtl
     , optics
     , resource-pool
-    , spock
+    , servant
+    , servant-server
     , stm
     , text
     , time

package.yaml

@@ -41,7 +41,8 @@ dependencies:
   - conferer
   - aeson
 
-  - spock
+  - servant
+  - servant-server
   - wai-websockets
   - websockets
 

src/API/Server.hs

@@ -0,0 +1,23 @@
+module API.Server where
+
+import Control.Monad.IO.Class (MonadIO (..))
+import Infrastructure.App (AppM)
+import Servant
+import Servant.API
+
+type SampleAPI =
+    Get '[JSON] String
+        :<|> Capture "text" String :> Get '[JSON] String
+
+type API = "sample" :> SampleAPI
+
+sampleServerM :: ServerT SampleAPI AppM
+sampleServerM = getString :<|> getStringMulti
+  where
+    getString = do
+        liftIO . print $ "Hello Empty"
+        return "Hello"
+
+    getStringMulti t = do
+        liftIO . print $ t ++ "Hello"
+        return $ t ++ "Hello"

src/Data/Persist/Tap.hs

@@ -30,3 +30,4 @@ data Tap = Tap
     deriving (Show, Eq, Generic)
 
 newtype CreateTap = CreateTap Tap
+

src/Domain/Sample.hs

@@ -0,0 +1,8 @@
+module Domain.Sample where
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Env.Cache (MonadCache (readCache))
+
+getSample :: (MonadCache m) => Text -> m Text
+getSample = fmap (fromMaybe "Nothing") . readCache

src/Env/Cache.hs

@@ -4,4 +4,4 @@ import Data.Text (Text)
 
 class (Monad m) => MonadCache m where
     writeCache :: Text -> Text -> m ()
-    readCache :: Text -> m (Maybe String)
+    readCache :: Text -> m (Maybe Text)

src/Infrastructure/App.hs

@@ -0,0 +1,18 @@
+module Infrastructure.App (AppEnv (..), AppM) where
+
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Reader (MonadReader (ask), ReaderT, asks)
+import Control.Monad.Reader.Class (MonadReader)
+import Infrastructure.Mongo (MonadMongo (runMongo), MongoEnv, runMongoM)
+
+newtype AppEnv = AppEnv
+    { appMongoEnv :: MongoEnv
+    }
+
+newtype AppM a = AppM {unAppM :: ReaderT AppEnv IO a}
+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv)
+
+instance MonadMongo AppM where
+    runMongo mm = AppM $ do
+        mongoEnv <- asks appMongoEnv
+        liftIO $ runMongoM mongoEnv mm

src/Infrastructure/Mongo.hs

@@ -1,7 +1,7 @@
-module Infrastructure.Mongo where
+module Infrastructure.Mongo (MongoEnv (..), MonadMongo (..), MongoM (..), mkMongoEnv, runMongoAction, runMongoM) where
 
 import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.Reader (MonadReader (ask))
+import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT))
 import Control.Monad.Trans.Reader (ReaderT)
 import Data.Pool (Pool, PoolConfig, defaultPoolConfig, newPool, withResource)
 import Data.Text (Text)
@@ -14,6 +14,9 @@ data MongoEnv = MongoEnv
     , mongoDBName :: Text
     }
 
+class (Monad m) => MonadMongo m where
+    runMongo :: MongoM a -> m a
+
 newtype MongoM a = MongoM {unMongoM :: ReaderT MongoEnv IO a}
     deriving (Functor, Applicative, Monad, MonadIO, MonadReader MongoEnv)
 
@@ -39,3 +42,6 @@ runMongoAction action = do
     MongoEnv{mongoPool, mongoDBName} <- ask
     liftIO $ withResource mongoPool $ \pipe ->
         access pipe master mongoDBName action
+
+runMongoM :: MongoEnv -> MongoM a -> IO a
+runMongoM env (MongoM r) = runReaderT r env

src/Infrastructure/Persist/Tap.hs

@@ -6,7 +6,7 @@ import Data.Text (Text)
 import Database.MongoDB
 import qualified Database.MongoDB as M
 import Env.Persist.Tap (MonadTaps (..))
-import Infrastructure.Mongo (MongoM, runMongoAction)
+import Infrastructure.Mongo (MonadMongo (runMongo), MongoM, runMongoAction)
 import Serialize.Bson (BsonTrans (fromBson, toBson))
 import Serialize.Str (StrTrans (..))
 
@@ -46,14 +46,14 @@ instance BsonTrans Tap where
 tapCollection :: Collection
 tapCollection = "taps"
 
-instance MonadTaps MongoM where
+instance (Monad m, MonadMongo m) => MonadTaps m where
-    createTap (CreateTap tap) = runMongoAction $ do
+    createTap (CreateTap tap) = runMongo . runMongoAction $ do
         insert tapCollection $ toBson tap
         return tap
 
-    getTap id = runMongoAction $ do
+    getTap id = runMongo . runMongoAction $ do
         doc <- findOne (select ["id" =: id] tapCollection)
         return $ fromBson =<< doc
 
-    deleteTap id = runMongoAction $ do
+    deleteTap id = runMongo . runMongoAction $ do
         delete (select ["id" =: id] tapCollection)