From 0798cb81a6f43aa6da0ff0e3f670b47165abd0f8 Mon Sep 17 00:00:00 2001
From: "Adam C. Baker" <adam.durandal@gmail.com>
Date: Fri, 17 Oct 2014 16:59:37 -0700
Subject: [PATCH] App has database pools!

---
 dbapi.cabal                |  2 +-
 src/Main.hs                | 18 ++++--------------
 src/Middleware.hs          |  5 ++---
 test/Feature/InsertSpec.hs |  2 +-
 4 files changed, 8 insertions(+), 19 deletions(-)

diff --git a/dbapi.cabal b/dbapi.cabal
index 088dbfd65..d2218e9a8 100644
--- a/dbapi.cabal
+++ b/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
diff --git a/src/Main.hs b/src/Main.hs
index fb1be07be..e840202d5 100644
--- a/src/Main.hs
+++ b/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"
diff --git a/src/Middleware.hs b/src/Middleware.hs
index 80f6c4054..8de8bf8fa 100644
--- a/src/Middleware.hs
+++ b/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
diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs
index 6678fba7f..1ba540415 100644
--- a/test/Feature/InsertSpec.hs
+++ b/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 = []
           }