From 9a8bd089e5b05a3e19dd83f44fac9cdd1338bc19 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sat, 12 Oct 2024 17:38:22 -0500 Subject: [PATCH] Add a simple logging effect and adapt only at IO sites --- README.md | 2 ++ src/Core.hs | 45 ++++++++++++++++++++++++++++++++++++++---- src/Database.hs | 52 +++++++++++++++++++++---------------------------- src/Main.hs | 13 +++++++++++-- 4 files changed, 76 insertions(+), 36 deletions(-) diff --git a/README.md b/README.md index fb5cf51..e6a6333 100644 --- a/README.md +++ b/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. diff --git a/src/Core.hs b/src/Core.hs index a8e4d03..c431b92 100644 --- a/src/Core.hs +++ b/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 diff --git a/src/Database.hs b/src/Database.hs index b82f068..04a083f 100644 --- a/src/Database.hs +++ b/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 - DatabaseWrite (statement, values) -> adapt $ write statement values + DatabaseRead (statement, values) -> read 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 - DatabaseWrite (statement, values) -> adapt $ write statement values + DatabaseRead (statement, values) -> read statement values + DatabaseWrite (statement, values) -> write statement values where - read :: Query -> Int -> IO (Maybe User) - read statement values = do - conn <- openConn - user <- query conn statement (Only values) - pure $ listToMaybe user - 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" + read :: DatabaseEffects es => Query -> Int -> Eff es (Maybe User) + read statement values = do + conn <- adapt $ openConn + users <- adapt $ query conn statement (Only values) + pure $ listToMaybe users -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 = [] - } + write :: DatabaseEffects es => Query -> String -> Eff es () + write statement values = do + conn <- adapt openConn + adapt $ 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" queryUser :: Int -> (Query, Int) queryUser userId = ("SELECT id, name FROM users WHERE id = ?;", userId) diff --git a/src/Main.hs b/src/Main.hs index 9809e1a..4b2247c 100644 --- a/src/Main.hs +++ b/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 . - runEff . runErrorNoCallStack . runFileSystem . runDatabaseIO +α = hoistServer proxy + $ Handler + . ExceptT + . runEff + . runErrorNoCallStack + . runLoggerIO + . runFileSystem + . runDatabaseIO port :: Int port = 8080