Further generalize the Database effect so that it can be used with data besides User

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)
+  DatabaseRead  :: (ToField a, Show a, FromRow b) => (Query, a) -> Database (Eff es) [b]
-  DatabaseWrite :: (Query, String) -> Database (Eff es) ()
+  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

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
+  DatabaseRead  (statement, values) -> do
-  DatabaseWrite (statement, values)  -> write statement values
+    writeLog
-  where
+       $ "Mocked a READ database operation with statement:\n"
-    read  _ values = 
+      ++ show statement
-      writeLog "Mocked a READ database operation" >>= \_ -> pure $ 
+      ++ " and values:\n"
-        Just (User values "Mock User")
+      ++ show values
-    write _ values = writeLog $ 
+    pure []
-      "Mocked a WRITE database operation with a user named " ++ values
+  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)
+        query conn statement (Only values)
-        pure $ listToMaybe r
+    read_ :: (FromRow b, DatabaseEffects es) => Query -> Eff es [b]
-
+    read_ statement = do
-    write :: DatabaseEffects es => Query -> String -> Eff es ()
+      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
+      writeLog $ "Wrote to database using statement:\n" ++ show statement
-
-    openConn :: IO Connection
-    openConn = connectPostgreSQL "host=localhost port=5432 dbname=demo connect_timeout=10"
 
 createConnectionPool :: IO (Pool Connection)
 createConnectionPool = newPool $ defaultPoolConfig

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
+    (a:_) -> pure a
-    Nothing -> pure (User 0 "No user found")
+    []    -> 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