Cleanup type signatures and start working on debug env run

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
+instance ToJSON   UserId
-    fromRow = User <$> field <*> field
+instance FromJSON UserId
-instance ToRow User where
+
-    toRow (User uid name) = toRow (uid, name)
+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

src/Database.hs

@@ -23,25 +23,54 @@ type DatabaseExeEffects es = ( Reader AppEnv :> es
                              , IOE :> es
                              )
 
-databaseInit 
+databaseInit :: (Database :> es, Error ServerError :> es) 
-  :: (Database :> es, Error ServerError :> es) => Eff es ()
+             => Eff es ()
 databaseInit = send DatabaseInit
 
-databaseRead
+databaseRead :: (ToField a, Show a, Database :> es, Error ServerError :> es)
-  :: (ToField a, Show a, Database :> es, Error ServerError :> es)
+             => (Query, a) -> Eff es [User]
-  => (Query, a) -> Eff es [User]
 databaseRead = send . DatabaseRead
 
-databaseRead_
+databaseRead_ :: (Database :> es, Error ServerError :> es) 
-  :: (Database :> es, Error ServerError :> es) => Query -> Eff es [User]
+              => Query -> Eff es [User]
 databaseRead_ = send . DatabaseRead_
 
-databaseWrite
+databaseWrite :: (ToRow a, Show a, Database :> es, Error ServerError :> es)
-  :: (ToRow a, Show a, Database :> es, Error ServerError :> es)
+              => (Query, a) -> Eff 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
+      $ "Mocked a WRITE database operation with statement:\n"
-
+     ++ show statement 
-runDatabaseIO :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
+     ++ "\nValues:\n"
-runDatabaseIO = interpret $ \_ -> \case
+     ++ show values
-  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
 
 createConnectionPool :: IO (Pool Connection)
 createConnectionPool = newPool $ defaultPoolConfig

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

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) => 
+runLoggerConsole :: (Error ServerError :> es, IOE :> es) 
-  Eff (Logger : es) a -> Eff es a
+                 => 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
-);
--}

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