diff --git a/.travis.yml b/.travis.yml index 49eb489c7..e61841843 100644 --- a/.travis.yml +++ b/.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 diff --git a/dbapi.cabal b/dbapi.cabal index 40dc7ce30..d2218e9a8 100644 --- a/dbapi.cabal +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 16dc35d24..e840202d5 100644 --- a/src/Main.hs +++ b/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" diff --git a/src/Middleware.hs b/src/Middleware.hs index 9045c4703..092cc3e09 100644 --- a/src/Middleware.hs +++ b/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")