From 64bf8f337cf757ecc986ee6ccd82130339d7d70d Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sun, 13 Oct 2024 13:30:39 -0500 Subject: [PATCH] Cleanup --- HELPS.cabal | 2 ++ src/Core.hs | 65 ++----------------------------------------------- src/Database.hs | 23 +++++++++++++++++ src/Logger.hs | 24 ++++++++++++++++++ src/Main.hs | 2 ++ src/Routes.hs | 27 ++++++++++++++++++++ 6 files changed, 80 insertions(+), 63 deletions(-) create mode 100644 src/Logger.hs create mode 100644 src/Routes.hs diff --git a/HELPS.cabal b/HELPS.cabal index dc0b86c..0b625f3 100644 --- a/HELPS.cabal +++ b/HELPS.cabal @@ -51,4 +51,6 @@ executable Main Core Database Handlers + Logger + Routes default-language: GHC2021 diff --git a/src/Core.hs b/src/Core.hs index d082b3e..b2a865e 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -20,28 +20,7 @@ import Servant hiding ((:>), throwError) import qualified Servant as S -- --- Routes --- -type Root = Get '[PlainText] T.Text - -type UserList = "user" - S.:> Get '[JSON] [User] - -type UserGet = "user" - S.:> Capture "userId" Int - S.:> Get '[JSON] User - -type UserPost = "user" - S.:> ReqBody '[PlainText] String - S.:> PostCreated '[PlainText] NoContent - -type AppAPI = Root - :<|> UserList - :<|> UserGet - :<|> UserPost - --- --- Core data +-- Core data types -- data User = User { userId :: Int, userName :: String} deriving (Show, Generic) @@ -54,9 +33,6 @@ instance ToRow User where instance ToJSON User instance FromJSON User --- --- Effects --- type AppEff = Eff '[ Database , Reader AppEnv , FileSystem @@ -67,7 +43,6 @@ type AppEff = Eff '[ Database data AppEnv = AppEnv { pool :: Pool Connection } --- Database data Database :: Effect where DatabaseRead :: (ToField a, Show a, FromRow b) => (Query, a) -> Database (Eff es) [b] @@ -76,44 +51,8 @@ data Database :: Effect where DatabaseWrite :: (ToField a, Show a) => (Query, a) -> Database (Eff es) () -type instance DispatchOf Database = 'Dynamic - -type DatabaseEffects es = ( Reader AppEnv :> es - , Logger :> es - , Error ServerError :> es - , IOE :> es - ) - -databaseRead - :: (ToField a, Show a, Database :> es, Error ServerError :> es) - => (Query, a) -> Eff es [User] -databaseRead = send . DatabaseRead - -databaseRead_ - :: (Database :> es, Error ServerError :> es) => Query -> Eff es [User] -databaseRead_ = send . DatabaseRead_ - -databaseWrite - :: (ToField a, Show a, Database :> es, Error ServerError :> es) - => (Query, a) -> Eff es () -databaseWrite = send . DatabaseWrite - --- Logger data Logger :: Effect where - WriteLog :: String -> Logger (Eff es) () - -type instance DispatchOf Logger = 'Dynamic - -writeLog :: (Logger :> es, Error ServerError :> es) => String -> Eff es () -writeLog = send . WriteLog - -runLoggerIO :: (IOE :> es, Error ServerError :> es) => - Eff (Logger : es) a -> Eff es a -runLoggerIO = interpret $ \_ -> \case - WriteLog msg -> log msg - where - log :: (IOE :> es, Error ServerError :> es) => String -> Eff es () - log msg = liftIOE $ putStrLn msg + WriteLog :: String -> Logger (Eff es) () -- Utility liftIOE :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a diff --git a/src/Database.hs b/src/Database.hs index 8e4aed8..a003bc6 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -1,6 +1,7 @@ module Database where import Core +import Logger import Control.Exception (IOException) import Data.Aeson (ToJSON) @@ -15,6 +16,28 @@ import Effectful.Reader.Static import Effectful.State.Static.Local (State, get, put, evalState) import Servant hiding ((:>), throwError) +type instance DispatchOf Database = 'Dynamic + +type DatabaseEffects es = ( Reader AppEnv :> es + , Logger :> es + , Error ServerError :> es + , IOE :> es + ) + +databaseRead + :: (ToField a, Show a, Database :> es, Error ServerError :> es) + => (Query, a) -> Eff es [User] +databaseRead = send . DatabaseRead + +databaseRead_ + :: (Database :> es, Error ServerError :> es) => Query -> Eff es [User] +databaseRead_ = send . DatabaseRead_ + +databaseWrite + :: (ToField a, Show a, Database :> es, Error ServerError :> es) + => (Query, a) -> Eff es () +databaseWrite = send . DatabaseWrite + runDatabaseDebug :: DatabaseEffects es => Eff (Database : es) a -> Eff es a runDatabaseDebug = interpret $ \_ -> \case DatabaseRead (statement, values) -> do diff --git a/src/Logger.hs b/src/Logger.hs new file mode 100644 index 0000000..f0cdc2c --- /dev/null +++ b/src/Logger.hs @@ -0,0 +1,24 @@ +module Logger where + +import Core + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Error.Static (Error, throwError) +import Effectful.FileSystem +import Effectful.Reader.Static +import GHC.Generics (Generic) +import Servant hiding ((:>)) + +type instance DispatchOf Logger = 'Dynamic + +writeLog :: (Logger :> es, Error ServerError :> es) => String -> Eff es () +writeLog = send . WriteLog + +runLoggerIO :: (IOE :> es, Error ServerError :> es) => + Eff (Logger : es) a -> Eff es a +runLoggerIO = interpret $ \_ -> \case + WriteLog msg -> log msg + where + log :: (IOE :> es, Error ServerError :> es) => String -> Eff es () + log msg = liftIOE $ putStrLn msg diff --git a/src/Main.hs b/src/Main.hs index 31c0d21..e758fd2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,6 +3,8 @@ module Main (main) where import Core import Database import Handlers +import Logger +import Routes import Control.Monad.Except (ExceptT (ExceptT)) import Data.List diff --git a/src/Routes.hs b/src/Routes.hs new file mode 100644 index 0000000..2485dad --- /dev/null +++ b/src/Routes.hs @@ -0,0 +1,27 @@ +module Routes where + +import Core + +import qualified Data.Text as T +import Servant + +-- +-- Routes +-- +type Root = Get '[PlainText] T.Text + +type UserList = "user" + :> Get '[JSON] [User] + +type UserGet = "user" + :> Capture "userId" Int + :> Get '[JSON] User + +type UserPost = "user" + :> ReqBody '[PlainText] String + :> PostCreated '[PlainText] NoContent + +type AppAPI = Root + :<|> UserList + :<|> UserGet + :<|> UserPost