From 295977536512b52655eb766864759319bcc7b77a Mon Sep 17 00:00:00 2001 From: minco Date: Fri, 28 Nov 2025 20:21:30 +0900 Subject: [PATCH] sdgf --- hq-sample.cabal | 12 +++++++++--- package.yaml | 3 ++- src/API/Server.hs | 23 +++++++++++++++++++++++ src/Data/Persist/Tap.hs | 1 + src/Domain/Sample.hs | 8 ++++++++ src/Env/Cache.hs | 2 +- src/Infrastructure/App.hs | 18 ++++++++++++++++++ src/Infrastructure/Mongo.hs | 10 ++++++++-- src/Infrastructure/Persist/Tap.hs | 10 +++++----- 9 files changed, 75 insertions(+), 12 deletions(-) create mode 100644 src/API/Server.hs create mode 100644 src/Domain/Sample.hs create mode 100644 src/Infrastructure/App.hs diff --git a/hq-sample.cabal b/hq-sample.cabal index 8cee4a3..47f0074 100644 --- a/hq-sample.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index d25bbb8..db6c802 100644 --- a/package.yaml +++ b/package.yaml @@ -41,7 +41,8 @@ dependencies: - conferer - aeson - - spock + - servant + - servant-server - wai-websockets - websockets diff --git a/src/API/Server.hs b/src/API/Server.hs new file mode 100644 index 0000000..40364b1 --- /dev/null +++ b/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" diff --git a/src/Data/Persist/Tap.hs b/src/Data/Persist/Tap.hs index cdf29c1..5ae06e1 100644 --- a/src/Data/Persist/Tap.hs +++ b/src/Data/Persist/Tap.hs @@ -30,3 +30,4 @@ data Tap = Tap deriving (Show, Eq, Generic) newtype CreateTap = CreateTap Tap + diff --git a/src/Domain/Sample.hs b/src/Domain/Sample.hs new file mode 100644 index 0000000..3faba6c --- /dev/null +++ b/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 diff --git a/src/Env/Cache.hs b/src/Env/Cache.hs index 480c602..4d6589a 100644 --- a/src/Env/Cache.hs +++ b/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) diff --git a/src/Infrastructure/App.hs b/src/Infrastructure/App.hs new file mode 100644 index 0000000..8d78269 --- /dev/null +++ b/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 diff --git a/src/Infrastructure/Mongo.hs b/src/Infrastructure/Mongo.hs index 2c3ad20..4855261 100644 --- a/src/Infrastructure/Mongo.hs +++ b/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 diff --git a/src/Infrastructure/Persist/Tap.hs b/src/Infrastructure/Persist/Tap.hs index 962f848..397fde1 100644 --- a/src/Infrastructure/Persist/Tap.hs +++ b/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 - createTap (CreateTap tap) = runMongoAction $ do +instance (Monad m, MonadMongo m) => MonadTaps m where + 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)