Add a simple logging effect and adapt only at IO sites

README.md

@@ -7,3 +7,5 @@ A nix starting template for web projects utilizing
 - [Lucid](https://github.com/chrisdone/lucid)
 - [PostgreSQL](https://www.postgresql.org/)
 - [Servant](https://github.com/haskell-servant/servant)
+
+The repository has a simple CRUD implementation of a "Users" API which demonstrates how to use included effects, create your own effects, and bubble errors to Servant's `ServerError` type.

src/Core.hs

@@ -1,21 +1,25 @@
 module Core where
 
 import Control.Exception                  (IOException)
+import Control.Monad.Catch                (catch)
 import Data.Aeson                         (FromJSON, ToJSON)
 import qualified Data.Text                as T
+import Data.ByteString.Lazy.UTF8          (fromString)
 import Database.PostgreSQL.Simple         (Query)
 import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow)
-import Database.PostgreSQL.Simple.ToRow   (ToRow, toRow)
 import Database.PostgreSQL.Simple.ToField (ToField)
+import Database.PostgreSQL.Simple.ToRow   (ToRow, toRow)
 import Effectful
 import Effectful.Dispatch.Dynamic
-import Effectful.Error.Static             (Error)
+import Effectful.Error.Static             (Error, throwError)
 import Effectful.FileSystem
 import GHC.Generics                       (Generic)
-import Servant hiding                     ((:>))
+import Servant hiding                     ((:>), throwError)
 import qualified Servant                  as S
 
+--
 -- Core data
+--
 data User = User { userId :: Int, userName :: String}
   deriving (Show, Generic)
 
@@ -27,22 +31,55 @@ instance ToRow User where
 instance ToJSON User
 instance FromJSON User
 
+--
 -- Effects
-type AppEff = Eff '[Database, FileSystem, Error ServerError, IOE]
+--
+type AppEff = Eff '[Database, FileSystem, Logger, Error ServerError, IOE]
 
+-- Database
 data Database :: Effect where
   DatabaseRead  :: (Query, Int)    -> Database (Eff es) (Maybe User)
   DatabaseWrite :: (Query, String) -> Database (Eff es) ()
 
 type instance DispatchOf Database = 'Dynamic
 
+type DatabaseEffects es = (IOE :> es, Logger :> es, Error ServerError :> es)
+
 databaseRead  :: (Database :> es, Error ServerError :> es) => (Query, Int) -> Eff es (Maybe User)
 databaseRead  = send . DatabaseRead
 
 databaseWrite :: (Database :> es, Error ServerError :> es) => (Query, String) -> 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 -> adapt $ log msg
+  where
+    log :: String -> IO ()
+    log msg = putStrLn msg
+
+-- Utility
+adapt :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a
+adapt m = liftIO m `catch` \(e::IOException) ->
+    throwError $ ServerError
+    { errHTTPCode     = 500
+    , errReasonPhrase = "Internal Database Error"
+    , errBody         = fromString $ show e
+    , errHeaders      = []
+    }
+
+--
 -- 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

src/Database.hs

@@ -3,53 +3,45 @@ module Database where
 import Core
 
 import Control.Exception          (IOException)
-import Control.Monad.Catch        (catch)
 import Data.Aeson                 (ToJSON)
-import Data.ByteString.Lazy.UTF8  (fromString)
 import Data.Maybe                 (listToMaybe)
 import Database.PostgreSQL.Simple 
 import Effectful
 import Effectful.Dispatch.Dynamic
-import Effectful.Error.Static     (Error, HasCallStack, catchError, runErrorNoCallStack, throwError)
+import Effectful.Error.Static     (Error)
 import Servant hiding             ((:>), throwError)
 
-runDatabaseDebug :: (IOE :> es, Error ServerError :> es) => Eff (Database : es) a -> Eff es a
+runDatabaseDebug :: DatabaseEffects es => Eff (Database : es) a -> Eff es a
 runDatabaseDebug = interpret $ \_ -> \case
-  DatabaseRead  (statement, values)  -> adapt $ read  statement values
+  DatabaseRead  (statement, values)  -> read  statement values
-  DatabaseWrite (statement, values)  -> adapt $ write statement values
+  DatabaseWrite (statement, values)  -> write statement values
   where
     read  _ values = 
-      putStrLn "We just mocked a READ database operation" >>= \_ -> pure $ 
+      writeLog "We just mocked a READ database operation" >>= \_ -> pure $ 
         Just (User values "Mock User")
     write _ values = 
-      putStrLn $ "We just mocked a WRITE database operation with a user named " 
+      writeLog $ "We just mocked a WRITE database operation with a user named " 
         ++ values
 
-runDatabaseIO :: (IOE :> es, Error ServerError :> es) => Eff (Database : es) a -> Eff es a
+runDatabaseIO :: DatabaseEffects es => Eff (Database : es) a -> Eff es a
 runDatabaseIO = interpret $ \_ -> \case
-  DatabaseRead  (statement, values) -> adapt $ read  statement values
+  DatabaseRead  (statement, values) -> read  statement values
-  DatabaseWrite (statement, values) -> adapt $ write statement values
+  DatabaseWrite (statement, values) -> write statement values
   where
-    read  :: Query -> Int -> IO (Maybe User)
+    read :: DatabaseEffects es => Query -> Int -> Eff es (Maybe User)
     read statement values = do
-      conn <- openConn
+      conn  <- adapt $ openConn
-      user <- query conn statement (Only values)
+      users <- adapt $ query conn statement (Only values)
-      pure  $ listToMaybe user
+      pure $ listToMaybe users
-    write :: Query -> String -> IO ()
-    write statement values = do
-      conn <- openConn
-      execute conn statement (Only values)
-      putStrLn $ "Wrote user to database using statement:\n" ++ show statement
-    openConn = connectPostgreSQL "host=localhost port=5432 dbname=demo connect_timeout=10"
 
-adapt :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a
+    write :: DatabaseEffects es => Query -> String -> Eff es ()
-adapt m = liftIO m `catch` \(e::IOException) ->
+    write statement values = do
-  throwError $ ServerError
+      conn <- adapt openConn
-    { errHTTPCode     = 500
+      adapt $ execute conn statement (Only values)
-    , errReasonPhrase = "Internal Database Error"
+      writeLog $ "Wrote user to database using statement:\n" ++ show statement
-    , errBody         = fromString $ show e
+
-    , errHeaders      = []
+    openConn :: IO Connection
-    }
+    openConn = connectPostgreSQL "host=localhost port=5432 dbname=demo connect_timeout=10"
 
 queryUser :: Int -> (Query, Int)
 queryUser userId = ("SELECT id, name FROM users WHERE id = ?;", userId)

src/Main.hs

@@ -13,6 +13,9 @@ import Network.Wai.Handler.Warp (run)
 import Servant hiding           ((:>), throwError)
 import qualified Servant        as S
 
+--
+-- Application
+--
 main :: IO ()
 main = run port $ serve proxy app
 
@@ -23,8 +26,14 @@ app = α $ rootHandler
      :<|> userPostHandler
 
 α :: ServerT API AppEff -> ServerT API Handler
-α = hoistServer proxy $ Handler . ExceptT .
+α = hoistServer proxy 
-  runEff . runErrorNoCallStack . runFileSystem . runDatabaseIO
+  $ Handler 
+  . ExceptT 
+  . runEff 
+  . runErrorNoCallStack
+  . runLoggerIO
+  . runFileSystem
+  . runDatabaseIO
 
 port :: Int
 port = 8080