From 49f0bf7c3fbeeba2a867f9b4f72b556c072caac1 Mon Sep 17 00:00:00 2001 From: "Adam C. Baker" Date: Wed, 15 Oct 2014 18:10:02 -0700 Subject: [PATCH 1/5] broken attempts to work on concurrency --- dbapi.cabal | 22 ++++++++++------------ src/Main.hs | 15 ++++++++++++--- src/Middleware.hs | 17 ++++++++++++----- 3 files changed, 34 insertions(+), 20 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index 40dc7ce30..088dbfd65 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -11,29 +11,26 @@ cabal-version: >=1.10 executable dbapi main-is: Main.hs - ghc-options: -Wall -W -Werror + ghc-options: -Wall -W -threaded default-language: Haskell2010 build-depends: base >=4.6 && <5 , HDBC, HDBC-postgresql , 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..fb1be07be 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,15 @@ 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) +import System.Process + +import Control.Concurrent(threadDelay) + +import Network.HTTP.Types.Status +import Network.Wai argParser :: Parser AppConfig argParser = AppConfig @@ -29,8 +37,9 @@ argParser = AppConfig main :: IO () main = do conf <- execParser (info (helper <*> argParser) describe) - let port = configPort conf let dburi = configDbUri conf + pool <- createPool (putStrLn "creating connection" >> connectPostgreSQL' (configDbUri conf)) (\c-> putStrLn "destroying connection" >> disconnect c) 1 600 10 + let port = configPort conf unless (configSecure conf) $ putStrLn "WARNING, running in insecure mode, auth will be in plaintext" diff --git a/src/Middleware.hs b/src/Middleware.hs index 9045c4703..80f6c4054 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) @@ -15,6 +16,7 @@ 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) @@ -26,18 +28,23 @@ import Network.URI (URI(..), parseURI) import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole) import Codec.Binary.Base64.String (decode) -inTransaction :: (Connection -> Application) -> Connection -> Application + +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") -withSavepoint :: (Connection -> Application) -> Connection -> Application +withSavepoint :: (Connection -> Application) -> (Connection -> Application) withSavepoint app conn req respond = do runRaw conn "savepoint req_sp" catch (app conn req respond) (\e -> let _ = (e::SomeException) in runRaw conn "rollback to savepoint req_sp" >> throw e) authenticated :: BS.ByteString -> (Connection -> Application) -> - Connection -> Application + (Connection -> Application) authenticated anon app conn req respond = do attempt <- httpRequesterRole (requestHeaders req) case attempt of @@ -46,9 +53,9 @@ authenticated anon app conn req respond = do LoginFailed -> respond $ responseLBS status401 [] "Invalid username or password" LoginSuccess role -> - bracket_ (setRole conn role) (resetRole conn) $ app conn req respond + bracket_ (setRole conn role >> threadDelay 10000000) (resetRole conn) $ app conn req respond NoCredentials -> - bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond + bracket_ (setRole conn anon >> threadDelay 10000000) (resetRole conn) $ app conn req respond where httpRequesterRole :: RequestHeaders -> IO LoginAttempt From 0798cb81a6f43aa6da0ff0e3f670b47165abd0f8 Mon Sep 17 00:00:00 2001 From: "Adam C. Baker" Date: Fri, 17 Oct 2014 16:59:37 -0700 Subject: [PATCH 2/5] 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 = [] } From 2773ef3030ef8d4b4e1d2311afa38713112162cf Mon Sep 17 00:00:00 2001 From: "Adam C. Baker" Date: Fri, 17 Oct 2014 17:28:06 -0700 Subject: [PATCH 3/5] restore test --- test/Feature/InsertSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 1ba540415..6678fba7f 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: satisfyElem"} |] + matchBody = Just [json| {"error":"Failed to parse JSON payload. Failed reading: satisfy"} |] , matchStatus = 400 , matchHeaders = [] } From 25ce4c00c611ee5ad5c211008d768b465ead54bc Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 17 Oct 2014 18:13:48 -0700 Subject: [PATCH 4/5] Fix hlint --- src/Middleware.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Middleware.hs b/src/Middleware.hs index 8de8bf8fa..4bda46048 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -32,18 +32,18 @@ withDBConnection :: Pool Connection -> (Connection -> Application) -> Applicatio withDBConnection pool app req respond = withResource pool (\c -> app c req respond) -inTransaction :: (Connection -> Application) -> (Connection -> Application) +inTransaction :: (Connection -> Application) -> Connection -> Application inTransaction app conn req respond = finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit") -withSavepoint :: (Connection -> Application) -> (Connection -> Application) +withSavepoint :: (Connection -> Application) -> Connection -> Application withSavepoint app conn req respond = do runRaw conn "savepoint req_sp" catch (app conn req respond) (\e -> let _ = (e::SomeException) in runRaw conn "rollback to savepoint req_sp" >> throw e) -authenticated :: BS.ByteString -> (Connection -> Application) -> - (Connection -> Application) +authenticated :: BS.ByteString -> Connection -> Application -> + Connection -> Application authenticated anon app conn req respond = do attempt <- httpRequesterRole (requestHeaders req) case attempt of From 36eeec6b17d08285ab7bb7e670ab528830d59478 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 17 Oct 2014 18:16:10 -0700 Subject: [PATCH 5/5] Retry the sandbox curl on travis as needed --- .travis.yml | 2 +- src/Middleware.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) 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/src/Middleware.hs b/src/Middleware.hs index 4bda46048..092cc3e09 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -42,7 +42,7 @@ withSavepoint app conn req respond = do catch (app conn req respond) (\e -> let _ = (e::SomeException) in runRaw conn "rollback to savepoint req_sp" >> throw e) -authenticated :: BS.ByteString -> Connection -> Application -> +authenticated :: BS.ByteString -> (Connection -> Application) -> Connection -> Application authenticated anon app conn req respond = do attempt <- httpRequesterRole (requestHeaders req)