Add a simple logging effect and adapt only at IO sites

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