From 5a72b5fcdb8f206e0582ad755bdb94761a2db32a Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sun, 13 Oct 2024 12:00:45 -0500 Subject: [PATCH] Further generalize the Database effect so that it can be used with data besides User --- src/Core.hs | 12 ++++++++---- src/Database.hs | 41 ++++++++++++++++++++++++----------------- src/Handlers.hs | 6 +++--- 3 files changed, 35 insertions(+), 24 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index 911992b..223cbf4 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -55,17 +55,21 @@ data AppEnv = AppEnv { pool :: Pool Connection } -- Database data Database :: Effect where - DatabaseRead :: (Query, Int) -> Database (Eff es) (Maybe User) - DatabaseWrite :: (Query, String) -> Database (Eff es) () + DatabaseRead :: (ToField a, Show a, FromRow b) => (Query, a) -> Database (Eff es) [b] + DatabaseRead_ :: (FromRow b) => Query -> Database (Eff es) [b] + 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 :: (Database :> es, Error ServerError :> es) => (Query, Int) -> Eff es (Maybe User) +databaseRead :: (ToField a, Show a, Database :> es, Error ServerError :> es) => (Query, a) -> Eff es [User] databaseRead = send . DatabaseRead -databaseWrite :: (Database :> es, Error ServerError :> es) => (Query, String) -> Eff es () +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 diff --git a/src/Database.hs b/src/Database.hs index d513ba1..c6f7d1d 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -7,6 +7,7 @@ import Data.Aeson (ToJSON) import Data.Maybe (listToMaybe) import Data.Pool import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.ToField (ToField) import Effectful import Effectful.Dispatch.Dynamic import Effectful.Error.Static (Error) @@ -16,36 +17,42 @@ import Servant hiding ((:>), throwError) runDatabaseDebug :: DatabaseEffects es => Eff (Database : es) a -> Eff es a runDatabaseDebug = interpret $ \_ -> \case - DatabaseRead (statement, values) -> read statement values - DatabaseWrite (statement, values) -> write statement values - where - read _ values = - writeLog "Mocked a READ database operation" >>= \_ -> pure $ - Just (User values "Mock User") - write _ values = writeLog $ - "Mocked a WRITE database operation with a user named " ++ values + DatabaseRead (statement, values) -> do + writeLog + $ "Mocked a READ database operation with statement:\n" + ++ show statement + ++ " and values:\n" + ++ show values + pure [] + DatabaseRead_ statement -> do + writeLog "Mocked a READ database operation on all users" + pure [] + DatabaseWrite (statement, values) -> do + writeLog + $ "Mocked a WRITE database operation with a user named " ++ show values runDatabaseIO :: DatabaseEffects es => Eff (Database : es) a -> Eff es a runDatabaseIO = interpret $ \_ -> \case DatabaseRead (statement, values) -> read statement values + DatabaseRead_ statement -> read_ statement DatabaseWrite (statement, values) -> write statement values where - read :: DatabaseEffects es => Query -> Int -> Eff es (Maybe User) + read :: (ToField a, FromRow b, DatabaseEffects es) => Query -> a -> Eff es [b] read statement values = do AppEnv { pool } <- ask liftIOE $ withResource pool $ \conn -> do - r <- query conn statement (Only values) - pure $ listToMaybe r - - write :: DatabaseEffects es => Query -> String -> Eff es () + query conn statement (Only values) + read_ :: (FromRow b, DatabaseEffects es) => Query -> Eff es [b] + read_ statement = do + AppEnv { pool } <- ask + liftIOE $ withResource pool $ \conn -> do + query_ conn statement + write :: (DatabaseEffects es, ToField a) => Query -> a -> Eff es () write statement values = do AppEnv { pool } <- ask liftIOE $ withResource pool $ \conn -> do execute conn statement (Only values) - writeLog $ "Wrote user to database using statement:\n" ++ show statement - - openConn :: IO Connection - openConn = connectPostgreSQL "host=localhost port=5432 dbname=demo connect_timeout=10" + writeLog $ "Wrote to database using statement:\n" ++ show statement createConnectionPool :: IO (Pool Connection) createConnectionPool = newPool $ defaultPoolConfig diff --git a/src/Handlers.hs b/src/Handlers.hs index fbca203..2ce8486 100644 --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -17,13 +17,13 @@ rootHandler :: (Error ServerError :> es) => Eff es T.Text rootHandler = return "Hello, World!" userListHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => Eff es [User] -userListHandler = mapM userGetHandler [1, 2, 3] +userListHandler = databaseRead_ "SELECT id, name FROM users" userGetHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => Int -> Eff es User userGetHandler userId = databaseRead (queryUser userId) >>= \mUser -> case mUser of - Just a -> pure a - Nothing -> pure (User 0 "No user found") + (a:_) -> pure a + [] -> pure (User 0 "No user found") userPostHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => String -> Eff es NoContent userPostHandler name = databaseWrite (writeUser name) >>= \_ -> return NoContent