Use pooling and add a general Reader record to the stack by default

HELPS.cabal

@@ -42,6 +42,7 @@ executable Main
     , lucid
     , mtl
     , postgresql-simple
+    , resource-pool
     , servant-server
     , text
     , utf8-string

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)

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

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)
 

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