Merge branch 'pools'

.travis.yml

@@ -12,7 +12,7 @@ before_install:
   - travis_retry sudo apt-get install --force-yes happy-1.19.3 alex-3.1.3
   - export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.3/bin:$PATH
 install:
-  - curl http://bin.begriffs.com/dbapi/cabal-sandbox.tar.xz | tar xJ
+  - travis_retry curl http://bin.begriffs.com/dbapi/cabal-sandbox.tar.xz | tar xJ
   - chmod a+x .cabal-sandbox/bin/*
   - cabal sandbox init
   - cabal install --enable-test --dependencies-only

dbapi.cabal

@@ -18,22 +18,19 @@ executable dbapi
                      , warp, wai >= 3.0.1 && < 3.0.2
                      , wai-extra, wai-cors
                      , wai-middleware-static >= 0.6.0
-                     , HTTP, convertible
+                     , HTTP, convertible, http-types
                      , case-insensitive
-                     , http-types, scientific, time
-                     , bytestring, aeson, network >= 2.6
-                     , text , containers
+                     , scientific, time
+                     , aeson, network >= 2.6
+                     , bytestring, text, split, string-conversions
+                     , containers, unordered-containers
                      , optparse-applicative >= 0.9.1 && < 0.10
-                     , unordered-containers
-                     , regex-base
-                     , string-conversions
-                     , http-media, regex-tdfa
+                     , regex-base, regex-tdfa
                      , Ranged-sets
                      , transformers
-                     , bcrypt
-                     , base64-string
-                     , split
+                     , bcrypt, base64-string
                      , network-uri >= 2.6
+                     , resource-pool, process
   Other-Modules:       Dbapi
                      , PgStructure
                      , PgQuery
@@ -69,3 +66,4 @@ Test-Suite spec
                      , base64-string
                      , split
                      , network-uri >= 2.6
+                     , resource-pool

src/Main.hs

@@ -3,9 +3,8 @@
 module Main where
 import Dbapi
 import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
-  redirectInsecure)
+  redirectInsecure, withDBConnection)
 import Network.Wai.Handler.Warp hiding (Connection)
-import Database.HDBC.PostgreSQL (connectPostgreSQL')
 import Data.String.Conversions (cs)
 
 import Control.Monad (unless)
@@ -14,6 +13,9 @@ import Options.Applicative hiding (columns)
 import Network.Wai.Middleware.Gzip (gzip, def)
 import Network.Wai.Middleware.Cors (cors)
 import Network.Wai.Middleware.Static (staticPolicy, only)
+import Database.HDBC (disconnect)
+import Database.HDBC.PostgreSQL(connectPostgreSQL')
+import Data.Pool(createPool)
 
 argParser :: Parser AppConfig
 argParser = AppConfig
@@ -29,20 +31,17 @@ argParser = AppConfig
 main :: IO ()
 main = do
   conf <- execParser (info (helper <*> argParser) describe)
+  pool <- createPool (connectPostgreSQL' (configDbUri conf)) disconnect 1 600 10
   let port = configPort conf
-  let dburi = configDbUri 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

@@ -6,6 +6,7 @@ module Middleware where
 import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
 import Data.Maybe (fromMaybe)
 import Data.Monoid (mconcat)
+import Data.Pool(withResource, Pool)
 
 import Database.HDBC (runRaw)
 import Database.HDBC.PostgreSQL (Connection)
@@ -26,6 +27,11 @@ import Network.URI (URI(..), parseURI)
 import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
+
+withDBConnection :: Pool Connection -> (Connection -> Application) -> Application
+withDBConnection pool app req respond =
+  withResource pool (\c -> app c req respond)
+
 inTransaction :: (Connection -> Application) -> Connection -> Application
 inTransaction app conn req respond =
   finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")