From d8f5110b02d9318da9b1f326c4350759672cc109 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sun, 13 Oct 2024 10:40:51 -0500 Subject: [PATCH] Use pooling and add a general Reader record to the stack by default --- HELPS.cabal | 1 + README.md | 2 +- src/Core.hs | 19 ++++++++++++------- src/Database.hs | 37 ++++++++++++++++++++++++------------- src/Main.hs | 16 +++++++++++----- 5 files changed, 49 insertions(+), 26 deletions(-) diff --git a/HELPS.cabal b/HELPS.cabal index 1444d34..dc0b86c 100644 --- a/HELPS.cabal +++ b/HELPS.cabal @@ -42,6 +42,7 @@ executable Main , lucid , mtl , postgresql-simple + , resource-pool , servant-server , text , utf8-string diff --git a/README.md b/README.md index e6a6333..3db230b 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # servant-effectful-template -A nix starting template for web projects utilizing +A work in progress Nix starting template for web projects utilizing - [Haskell](https://wiki.haskell.org/Haskell) - [Effectful](https://github.com/haskell-effectful/effectful) diff --git a/src/Core.hs b/src/Core.hs index 86f3abe..911992b 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -5,7 +5,8 @@ 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 Data.Pool (Pool) +import Database.PostgreSQL.Simple (Connection, Query) import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow) import Database.PostgreSQL.Simple.ToField (ToField) import Database.PostgreSQL.Simple.ToRow (ToRow, toRow) @@ -13,6 +14,7 @@ import Effectful import Effectful.Dispatch.Dynamic import Effectful.Error.Static (Error, throwError) import Effectful.FileSystem +import Effectful.Reader.Static import GHC.Generics (Generic) import Servant hiding ((:>), throwError) import qualified Servant as S @@ -47,7 +49,9 @@ instance FromJSON User -- -- Effects -- -type AppEff = Eff '[Database, FileSystem, Logger, Error ServerError, IOE] +type AppEff = Eff '[Database, Reader AppEnv, FileSystem, Logger, Error ServerError, IOE] + +data AppEnv = AppEnv { pool :: Pool Connection } -- Database data Database :: Effect where @@ -56,10 +60,10 @@ data Database :: Effect where type instance DispatchOf Database = 'Dynamic -type DatabaseEffects es = (IOE :> es, Logger :> es, Error ServerError :> es) +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 = send . DatabaseRead +databaseRead = send . DatabaseRead databaseWrite :: (Database :> es, Error ServerError :> es) => (Query, String) -> Eff es () databaseWrite = send . DatabaseWrite @@ -78,11 +82,12 @@ runLoggerIO = interpret $ \_ -> \case WriteLog msg -> log msg where log :: (IOE :> es, Error ServerError :> es) => String -> Eff es () - log msg = adapt $ putStrLn msg + log msg = liftIOE $ putStrLn msg -adapt :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a +-- Utility +liftIOE :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a -- Lift IO into Eff and catch IOExceptions -adapt m = liftIO m `catch` \(e::IOException) -> do +liftIOE m = liftIO m `catch` \(e::IOException) -> do -- Log IOExceptions to stdout liftIO $ putStrLn $ "ERROR Exception: " ++ show e -- Throw a custom Servant ServerError diff --git a/src/Database.hs b/src/Database.hs index 9d796e7..d513ba1 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -2,14 +2,17 @@ module Database where import Core -import Control.Exception (IOException) -import Data.Aeson (ToJSON) -import Data.Maybe (listToMaybe) +import Control.Exception (IOException) +import Data.Aeson (ToJSON) +import Data.Maybe (listToMaybe) +import Data.Pool import Database.PostgreSQL.Simple import Effectful import Effectful.Dispatch.Dynamic -import Effectful.Error.Static (Error) -import Servant hiding ((:>), throwError) +import Effectful.Error.Static (Error) +import Effectful.Reader.Static +import Effectful.State.Static.Local (State, get, put, evalState) +import Servant hiding ((:>), throwError) runDatabaseDebug :: DatabaseEffects es => Eff (Database : es) a -> Eff es a runDatabaseDebug = interpret $ \_ -> \case @@ -19,9 +22,8 @@ runDatabaseDebug = interpret $ \_ -> \case read _ values = writeLog "Mocked a READ database operation" >>= \_ -> pure $ Just (User values "Mock User") - write _ values = - writeLog $ "Mocked a WRITE database operation with a user named " - ++ values + write _ values = writeLog $ + "Mocked a WRITE database operation with a user named " ++ values runDatabaseIO :: DatabaseEffects es => Eff (Database : es) a -> Eff es a runDatabaseIO = interpret $ \_ -> \case @@ -30,19 +32,28 @@ runDatabaseIO = interpret $ \_ -> \case where 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 + AppEnv { pool } <- ask + liftIOE $ withResource pool $ \conn -> do + r <- query conn statement (Only values) + pure $ listToMaybe r write :: DatabaseEffects es => Query -> String -> Eff es () write statement values = do - conn <- adapt openConn - adapt $ execute conn statement (Only values) + AppEnv { pool } <- ask + liftIOE $ withResource pool $ \conn -> do + 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" +createConnectionPool :: IO (Pool Connection) +createConnectionPool = newPool $ defaultPoolConfig + (connectPostgreSQL "host=localhost dbname=demo") + close + 60 + 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 58a6d5d..201c9af 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,6 +9,7 @@ import Data.List import Effectful import Effectful.Error.Static (Error, runError, runErrorNoCallStack, throwError) import Effectful.FileSystem +import Effectful.Reader.Static import Network.Wai.Handler.Warp (run) import Servant hiding ((:>), throwError) import qualified Servant as S @@ -17,22 +18,27 @@ import qualified Servant as S -- Application -- main :: IO () -main = run port $ serve proxy app +main = do + pool <- createConnectionPool + let env = AppEnv { pool = pool } + run port $ serve proxy $ app env -app :: Server AppAPI -app = α $ rootHandler +app :: AppEnv -> Server AppAPI +app env = transformEff env + $ rootHandler :<|> userListHandler :<|> userGetHandler :<|> userPostHandler -α :: ServerT AppAPI AppEff -> ServerT AppAPI Handler -α = hoistServer proxy +transformEff :: AppEnv -> ServerT AppAPI AppEff -> ServerT AppAPI Handler +transformEff env = hoistServer proxy $ Handler . ExceptT . runEff . runErrorNoCallStack . runLoggerIO . runFileSystem + . runReader env . runDatabaseIO port :: Int