App has database pools!

src/Main.hs

@@ -16,12 +16,6 @@ import Network.Wai.Middleware.Static (staticPolicy, only)
 import Database.HDBC (disconnect)
 import Database.HDBC.PostgreSQL(connectPostgreSQL')
 import Data.Pool(createPool)
-import System.Process
-
-import Control.Concurrent(threadDelay)
-
-import Network.HTTP.Types.Status
-import Network.Wai
 
 argParser :: Parser AppConfig
 argParser = AppConfig
@@ -37,21 +31,17 @@ argParser = AppConfig
 main :: IO ()
 main = do
   conf <- execParser (info (helper <*> argParser) describe)
-  let dburi = configDbUri conf
-  pool <- createPool (putStrLn "creating connection" >> connectPostgreSQL' (configDbUri conf)) (\c-> putStrLn "destroying connection" >> disconnect c) 1 600 10
+  pool <- createPool (connectPostgreSQL' (configDbUri conf)) disconnect 1 600 10
   let port = configPort conf
 
   unless (configSecure conf) $
     putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
 
   Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
-  conn <- connectPostgreSQL' dburi
   run port $ (if configSecure conf then redirectInsecure else id)
-    . gzip def
-    . cors corsPolicy
-    . clientErrors
+    . gzip def . cors corsPolicy . clientErrors
     . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
-    $ (inTransaction . authenticated (cs $ configAnonRole conf) . withSavepoint)
-    app conn
+    . withDBConnection pool . inTransaction
+    . authenticated (cs $ configAnonRole conf) . withSavepoint $ app
   where
     describe = progDesc "create a REST API to an existing Postgres database"

src/Middleware.hs

@@ -16,7 +16,6 @@ import Data.String.Conversions(cs)
 import qualified Data.ByteString.Char8 as BS
 import Control.Exception (finally, throw, catchJust, catch, SomeException,
     bracket_)
-import Control.Concurrent(threadDelay)
 
 import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
   hLocation)
@@ -53,9 +52,9 @@ authenticated anon app conn req respond = do
     LoginFailed ->
       respond $ responseLBS status401 [] "Invalid username or password"
     LoginSuccess role ->
-      bracket_ (setRole conn role >> threadDelay 10000000) (resetRole conn) $ app conn req respond
+      bracket_ (setRole conn role) (resetRole conn) $ app conn req respond
     NoCredentials ->
-      bracket_ (setRole conn anon >> threadDelay 10000000) (resetRole conn) $ app conn req respond
+      bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond
 
  where
    httpRequesterRole :: RequestHeaders -> IO LoginAttempt