App has database pools!

dbapi.cabal

@@ -11,7 +11,7 @@ cabal-version:         >=1.10
 
 executable dbapi
   main-is:             Main.hs
-  ghc-options:         -Wall -W -threaded
+  ghc-options:         -Wall -W -Werror
   default-language:    Haskell2010
   build-depends:       base >=4.6 && <5
                      , HDBC, HDBC-postgresql

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

test/Feature/InsertSpec.hs

@@ -72,7 +72,7 @@ spec = around appWithFixture $ do
       it "fails with 400 and error" $
         post "/simple_pk" "}{ x = 2"
           `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [json| {"error":"Failed to parse JSON payload. Failed reading: satisfy"} |]
+            matchBody    = Just [json| {"error":"Failed to parse JSON payload. Failed reading: satisfyElem"} |]
           , matchStatus  = 400
           , matchHeaders = []
           }