From ffec891f269d69cee4a4cdc012b354f4bfb39226 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Wed, 16 Oct 2024 08:10:10 -0500 Subject: [PATCH] Cleanup type signatures and start working on debug env run --- src/Core.hs | 21 +++++------ src/Database.hs | 95 +++++++++++++++++++++++-------------------------- src/Handlers.hs | 15 +++++--- src/Logger.hs | 18 +++------- src/Main.hs | 7 ++++ 5 files changed, 77 insertions(+), 79 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index c79581a..7e8b54b 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -32,22 +32,23 @@ data AppEnv = AppEnv { pool :: Pool Connection } newtype UserId = UserId Int deriving (Show, Generic, FromField, ToField, FromHttpApiData, ToHttpApiData) -instance ToJSON UserId -instance FromJSON UserId -instance ToRow UserId -instance FromRow UserId - data User = User { userId :: UserId, userName :: T.Text} deriving (Show, Generic) -instance FromRow User where - fromRow = User <$> field <*> field -instance ToRow User where - toRow (User uid name) = toRow (uid, name) +instance ToJSON UserId +instance FromJSON UserId + +instance ToRow UserId +instance FromRow UserId instance ToJSON User instance FromJSON User +instance ToRow User where + toRow (User uid name) = toRow (uid, name) +instance FromRow User where + fromRow = User <$> field <*> field + data Database :: Effect where DatabaseInit :: Database (Eff es) () @@ -58,7 +59,7 @@ data Database :: Effect where DatabaseWrite :: (ToRow a, Show a) => (Query, a) -> Database (Eff es) () -data Logger :: Effect where +data Logger :: Effect where WriteLog :: LogLevel -> String -> Logger (Eff es) () data LogLevel = Info | Warning | Error diff --git a/src/Database.hs b/src/Database.hs index 1c6af68..bceefe2 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -23,25 +23,54 @@ type DatabaseExeEffects es = ( Reader AppEnv :> es , IOE :> es ) -databaseInit - :: (Database :> es, Error ServerError :> es) => Eff es () +databaseInit :: (Database :> es, Error ServerError :> es) + => Eff es () databaseInit = send DatabaseInit -databaseRead - :: (ToField a, Show a, Database :> es, Error ServerError :> es) - => (Query, a) -> Eff es [User] +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_ :: (Database :> es, Error ServerError :> es) + => Query -> Eff es [User] databaseRead_ = send . DatabaseRead_ -databaseWrite - :: (ToRow a, Show a, Database :> es, Error ServerError :> es) - => (Query, a) -> Eff es () +databaseWrite :: (ToRow a, Show a, Database :> es, Error ServerError :> es) + => (Query, a) -> Eff es () databaseWrite = send . DatabaseWrite -runDatabaseDebug :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a +runDatabaseIO :: DatabaseExeEffects es + => Eff (Database : es) a -> Eff es a +runDatabaseIO = interpret $ \_ -> \case + DatabaseInit -> do + AppEnv { pool } <- ask + liftWithPool pool $ \conn -> do + execute_ conn createUsersTable + execute_ conn createLogsTable + pure () + + DatabaseRead (statement, values) -> do + AppEnv { pool } <- ask + liftWithPool pool $ \conn -> + query conn statement (Only values) + + DatabaseRead_ statement -> do + AppEnv { pool } <- ask + liftWithPool pool $ \conn -> + query_ conn statement + + DatabaseWrite (statement, values) -> do + AppEnv { pool } <- ask + liftWithPool pool $ \conn -> do + execute conn statement values + pure () + where + liftWithPool :: (IOE :> es, Error ServerError :> es) + => (Pool Connection) -> (Connection -> IO a) -> Eff es a + liftWithPool p f = liftIOE $ withResource p f + +runDatabaseDebug :: DatabaseExeEffects es + => Eff (Database : es) a -> Eff es a runDatabaseDebug = interpret $ \_ -> \case DatabaseInit -> do liftIOE $ putStrLn "Mocked setup of the database" @@ -49,7 +78,7 @@ runDatabaseDebug = interpret $ \_ -> \case liftIOE $ putStrLn $ "Mocked a READ database operation with statement:\n" ++ show statement - ++ " and values:\n" + ++ "\nValues:\n" ++ show values pure [] DatabaseRead_ statement -> do @@ -57,44 +86,10 @@ runDatabaseDebug = interpret $ \_ -> \case pure [] DatabaseWrite (statement, values) -> do liftIOE $ putStrLn - $ "Mocked a WRITE database operation with a user named " ++ show values - -runDatabaseIO :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a -runDatabaseIO = interpret $ \_ -> \case - DatabaseInit -> init - DatabaseRead (statement, values) -> read statement values - DatabaseRead_ statement -> read_ statement - DatabaseWrite (statement, values) -> write statement values - where - init :: DatabaseExeEffects es => Eff es () - init = do - AppEnv { pool } <- ask - liftWithPool pool $ \conn -> do - execute_ conn createUsersTable - execute_ conn createLogsTable - pure () - - read :: (ToField a, FromRow b, DatabaseExeEffects es) - => Query -> a -> Eff es [b] - read statement values = do - AppEnv { pool } <- ask - liftWithPool pool $ \conn -> - query conn statement (Only values) - - read_ :: (FromRow b, DatabaseExeEffects es) => Query -> Eff es [b] - read_ statement = do - AppEnv { pool } <- ask - liftWithPool pool $ \conn -> - query_ conn statement - - write :: (DatabaseExeEffects es, ToRow a) => Query -> a -> Eff es () - write statement values = do - AppEnv { pool } <- ask - liftWithPool pool $ \conn -> do - execute conn statement values - pure () - - liftWithPool p f = liftIOE $ withResource p f + $ "Mocked a WRITE database operation with statement:\n" + ++ show statement + ++ "\nValues:\n" + ++ show values createConnectionPool :: IO (Pool Connection) createConnectionPool = newPool $ defaultPoolConfig diff --git a/src/Handlers.hs b/src/Handlers.hs index 2d4f45f..0d2fd1c 100644 --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -14,24 +14,29 @@ import qualified Servant as S type CRUD es = ( Database :> es, Logger :> es, Error ServerError :> es ) -rootHandler :: (Logger :> es, Error ServerError :> es) => Eff es T.Text +rootHandler :: (Logger :> es, Error ServerError :> es) + => Eff es T.Text rootHandler = (writeLog Info "Hit the root!") >>= \_ -> return "Hello, World!" -userListHandler :: CRUD es => Eff es [User] +userListHandler :: CRUD es + => Eff es [User] userListHandler = (writeLog Info "Selected all users!") >>= \_ -> databaseRead_ "SELECT id, name FROM users" -userGetHandler :: CRUD es => UserId -> Eff es User +userGetHandler :: CRUD es + => UserId -> Eff es User userGetHandler userId = databaseRead (queryUser userId) >>= \mUser -> case mUser of (a:_) -> pure a [] -> pure (User (UserId 0) "No user found") -userPostHandler :: CRUD es => T.Text -> Eff es NoContent +userPostHandler :: CRUD es + => T.Text -> Eff es NoContent userPostHandler name = databaseWrite (writeUser name) >>= \_ -> return NoContent -userDeleteHandler :: CRUD es => UserId -> Eff es NoContent +userDeleteHandler :: CRUD es + => UserId -> Eff es NoContent userDeleteHandler userId = databaseWrite (deleteUser userId) >>= \_ -> return NoContent diff --git a/src/Logger.hs b/src/Logger.hs index d000d6c..f0bf187 100644 --- a/src/Logger.hs +++ b/src/Logger.hs @@ -19,8 +19,8 @@ writeLog :: (Logger :> es, Error ServerError :> es) => LogLevel -> String -> Eff es () writeLog level msg = send (WriteLog level msg) -runLoggerConsole :: (Error ServerError :> es, IOE :> es) => - Eff (Logger : es) a -> Eff es a +runLoggerConsole :: (Error ServerError :> es, IOE :> es) + => Eff (Logger : es) a -> Eff es a runLoggerConsole = interpret $ \_ -> \case WriteLog level msg -> do time <- liftIOE getCurrentTime @@ -29,19 +29,9 @@ runLoggerConsole = interpret $ \_ -> \case ++ "LEVEL: " ++ show level ++ "\n" ++ "MESSAGE: " ++ msg -runLoggerPSQL :: LogToDatabase es => Eff (Logger : es) a -> Eff es a +runLoggerPSQL :: LogToDatabase es + => Eff (Logger : es) a -> Eff es a runLoggerPSQL = interpret $ \_ -> \case WriteLog level msg -> databaseWrite ("INSERT INTO logs (level, message) VALUES (?,?);", (level, msg)) - -{- -CREATE TABLE logs ( - id SERIAL PRIMARY KEY, - level VARCHAR(10) NOT NULL, - message TEXT NOT NULL, - timestamp TIMESTAMPTZ NOT NULL DEFAULT NOW(), - source VARCHAR(100), - context JSONB -); --} diff --git a/src/Main.hs b/src/Main.hs index 327e62e..7bf6cdb 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -42,6 +42,13 @@ runAppEff env = runEff . runDatabaseIO . runLoggerPSQL +runAppDebug :: AppEnv -> AppEff a -> IO (Either ServerError a) +runAppDebug env = runEff + . runErrorNoCallStack + . runReader env + . runDatabaseDebug + . runLoggerConsole + port :: Int port = 8080