From 52e689b830b509d831b1683a4c37706efd44e8bc Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 20 Feb 2016 17:40:16 -0800 Subject: [PATCH 01/18] Add concurrent test for "transaction in progress" MonadBaseControl wizardry courtesy of @jwiegley --- postgrest.cabal | 5 ++++ test/Feature/ConcurrentSpec.hs | 43 ++++++++++++++++++++++++++++++++++ test/Main.hs | 2 ++ 3 files changed, 50 insertions(+) create mode 100644 test/Feature/ConcurrentSpec.hs diff --git a/postgrest.cabal b/postgrest.cabal index 30b477626..f41e56f03 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -127,6 +127,7 @@ Test-Suite spec Hs-Source-Dirs: test, src Main-Is: Main.hs Other-Modules: Feature.AuthSpec + , Feature.ConcurrentSpec , Feature.CorsSpec , Feature.DeleteSpec , Feature.InsertSpec @@ -148,6 +149,7 @@ Test-Suite spec , SpecHelper , TestTypes Build-Depends: aeson + , async , base , base64-string , bytestring @@ -164,6 +166,7 @@ Test-Suite spec , http-types , interpolatedstring-perl6 , jwt + , monad-control , optparse-applicative , parsec , process @@ -173,6 +176,8 @@ Test-Suite spec , string-conversions , text , time + , transformers + , transformers-base , unordered-containers , vector , wai diff --git a/test/Feature/ConcurrentSpec.hs b/test/Feature/ConcurrentSpec.hs new file mode 100644 index 000000000..0440bc7a2 --- /dev/null +++ b/test/Feature/ConcurrentSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Feature.ConcurrentSpec where + +import Control.Monad (void) +import Control.Monad.Base + +import Control.Monad.Trans.Control +import Control.Concurrent.Async (mapConcurrently) + +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai.Internal +import Test.Hspec.Wai +import Network.Wai.Test (Session) +import qualified Hasql.Connection as H + +import SpecHelper +import PostgREST.Types (DbStructure(..)) + +spec :: DbStructure -> H.Connection -> Spec +spec struct c = around (withApp cfgDefault struct c) $ + + describe "Queryiny in parallel" $ + it "should not raise 'transaction in progress' error" $ + raceTest 3 $ + get "/fakefake" `shouldRespondWith` 404 + +raceTest :: Int -> WaiExpectation -> WaiExpectation +raceTest times = liftBaseDiscard go + where + go test = void $ mapConcurrently (const test) [1..times] + +instance MonadBaseControl IO WaiSession where + type StM WaiSession a = StM Session a + liftBaseWith f = WaiSession $ + liftBaseWith $ \runInBase -> + f $ \k -> runInBase (unWaiSession k) + restoreM = WaiSession . restoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadBase IO WaiSession where + liftBase = liftIO diff --git a/test/Main.hs b/test/Main.hs index 6256f5d98..b7d115b92 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -10,6 +10,7 @@ import PostgREST.DbStructure (getDbStructure) import Data.String.Conversions (cs) import qualified Feature.AuthSpec +import qualified Feature.ConcurrentSpec import qualified Feature.CorsSpec import qualified Feature.DeleteSpec import qualified Feature.InsertSpec @@ -34,6 +35,7 @@ main = do where specs conn dbStructure = do describe "Feature.AuthSpec" $ Feature.AuthSpec.spec dbStructure conn + describe "Feature.ConcurrentSpec" $ Feature.ConcurrentSpec.spec dbStructure conn describe "Feature.CorsSpec" $ Feature.CorsSpec.spec dbStructure conn describe "Feature.DeleteSpec" $ Feature.DeleteSpec.spec dbStructure conn describe "Feature.InsertSpec" $ Feature.InsertSpec.spec dbStructure conn From de848f64fa3c423b80af36c37733fdfbfc2ab7ec Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Tue, 16 Feb 2016 23:01:03 -0500 Subject: [PATCH 02/18] Return the results from withResource function before applying the respond continuation. This ensures that the pool resource is freed as soon as the database operation is complete --- src/PostgREST/Main.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 3701e36a7..8e6506e1a 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -97,8 +97,9 @@ main = do body <- strictRequestBody req let handleReq = H.run $ inTransaction ReadCommitted (runWithClaims conf time (app dbStructure conf body) req) - withResource pool $ \case - Left err -> respond $ errResponse HT.status500 (cs . show $ err) + res <- withResource pool $ \case + Left err -> return $ errResponse HT.status500 (cs . show $ err) Right c -> do resOrError <- handleReq c - either (respond . pgErrResponse) respond resOrError + either (return . pgErrResponse) return resOrError + respond res From 01ab540ffe1419798fdb4932b68abf7808d75926 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Wed, 17 Feb 2016 10:30:19 -0500 Subject: [PATCH 03/18] Simplify return from withResource in Main.hs --- src/PostgREST/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 8e6506e1a..fd1489b07 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -101,5 +101,5 @@ main = do Left err -> return $ errResponse HT.status500 (cs . show $ err) Right c -> do resOrError <- handleReq c - either (return . pgErrResponse) return resOrError + return $ either pgErrResponse id resOrError respond res From 8a006f07a78427e0435c9f793a53f608edd020e3 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 20 Feb 2016 18:11:46 -0800 Subject: [PATCH 04/18] Show error text more clearly --- test/Feature/ConcurrentSpec.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/test/Feature/ConcurrentSpec.hs b/test/Feature/ConcurrentSpec.hs index 0440bc7a2..7fd60d354 100644 --- a/test/Feature/ConcurrentSpec.hs +++ b/test/Feature/ConcurrentSpec.hs @@ -11,6 +11,7 @@ import Control.Concurrent.Async (mapConcurrently) import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai.Internal import Test.Hspec.Wai +import Test.Hspec.Wai.JSON import Network.Wai.Test (Session) import qualified Hasql.Connection as H @@ -23,7 +24,17 @@ spec struct c = around (withApp cfgDefault struct c) $ describe "Queryiny in parallel" $ it "should not raise 'transaction in progress' error" $ raceTest 3 $ - get "/fakefake" `shouldRespondWith` 404 + get "/fakefake" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| + { "hint": null, + "details":null, + "code":"42P01", + "message":"relation \"test.fakefake\" does not exist" + } |] + , matchStatus = 404 + , matchHeaders = [] + } raceTest :: Int -> WaiExpectation -> WaiExpectation raceTest times = liftBaseDiscard go From d7fe59f0b065c582971689b2a26b166ca6f6aa58 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 21 Feb 2016 12:22:18 -0800 Subject: [PATCH 05/18] WIP: share server code between tests and program - Share server code in Main - Switch to hasql-pool - Use pool in tests - DRY up test runner --- postgrest.cabal | 11 ++++-- src/PostgREST/Error.hs | 31 ++++++++++----- src/PostgREST/Main.hs | 65 ++++++++++++++------------------ stack.yaml | 1 + test/Feature/AuthSpec.hs | 8 ++-- test/Feature/ConcurrentSpec.hs | 9 ++--- test/Feature/CorsSpec.hs | 8 ++-- test/Feature/DeleteSpec.hs | 10 ++--- test/Feature/InsertSpec.hs | 7 ++-- test/Feature/QueryLimitedSpec.hs | 9 ++--- test/Feature/QuerySpec.hs | 7 ++-- test/Feature/RangeSpec.hs | 9 ++--- test/Feature/StructureSpec.hs | 8 ++-- test/Main.hs | 40 ++++++++++---------- test/SpecHelper.hs | 27 ------------- 15 files changed, 109 insertions(+), 141 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index f41e56f03..81b62457b 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -23,7 +23,7 @@ Flag CI executable postgrest main-is: PostgREST/Main.hs - default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase + default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 build-depends: aeson >= 0.8 && < 0.10 @@ -35,6 +35,7 @@ executable postgrest , contravariant , errors , hasql >= 0.19.3.3 && < 0.20 + , hasql-pool >= 0.4 && < 0.5 , http-types , interpolatedstring-perl6 , jwt @@ -42,7 +43,6 @@ executable postgrest , parsec , postgrest , regex-tdfa - , resource-pool , safe >= 0.3 && < 0.4 , scientific , string-conversions @@ -86,6 +86,7 @@ library , contravariant , errors , hasql + , hasql-pool , http-types , interpolatedstring-perl6 , jwt @@ -123,7 +124,7 @@ library Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010 - default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase + default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes Hs-Source-Dirs: test, src Main-Is: Main.hs Other-Modules: Feature.AuthSpec @@ -139,6 +140,7 @@ Test-Suite spec , PostgREST.Auth , PostgREST.Config , PostgREST.Error + , PostgREST.Main , PostgREST.Middleware , PostgREST.Parsers , PostgREST.DbStructure @@ -159,6 +161,7 @@ Test-Suite spec , contravariant , errors , hasql + , hasql-pool , heredoc , hspec == 2.2.* , hspec-wai @@ -179,10 +182,12 @@ Test-Suite spec , transformers , transformers-base , unordered-containers + , unix , vector , wai , wai-cors , wai-extra , wai-middleware-static + , warp , HTTP , Ranged-sets diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index e6629f5dd..03aa8523d 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -7,11 +7,13 @@ module PostgREST.Error (pgErrResponse, errResponse) where import Data.Aeson ((.=)) import qualified Data.Aeson as JSON +import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.String.Conversions (cs) import Data.Text (Text) import qualified Data.Text as T import qualified Hasql.Session as H +import qualified Hasql.Pool as P import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT import Network.Wai (Response, responseLBS) @@ -19,10 +21,17 @@ import Network.Wai (Response, responseLBS) errResponse :: HT.Status -> Text -> Response errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"]) -pgErrResponse :: H.Error -> Response +pgErrResponse :: P.UsageError -> Response pgErrResponse e = responseLBS (httpStatus e) [(hContentType, "application/json")] (JSON.encode e) +instance JSON.ToJSON P.UsageError where + toJSON (P.ConnectionError e) = JSON.object [ + "code" .= ("" :: T.Text), + "message" .= ("Connection error" :: T.Text), + "details" .= (cs (fromMaybe "" e) :: T.Text)] + toJSON e = JSON.toJSON e -- H.Error + instance JSON.ToJSON H.Error where toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [ "code" .= (cs c::T.Text), @@ -51,15 +60,17 @@ instance JSON.ToJSON H.Error where "message" .= ("Database client error"::String), "details" .= (fmap cs d::Maybe T.Text)] -httpStatus :: H.Error -> HT.Status -httpStatus (H.ResultError (H.ServerError c _ _ _)) = +httpStatus :: P.UsageError -> HT.Status +httpStatus (P.ConnectionError _) = + HT.status500 +httpStatus (P.SessionError (H.ResultError (H.ServerError c _ _ _))) = case cs c of '0':'8':_ -> HT.status503 -- pg connection err '0':'9':_ -> HT.status500 -- triggered action exception '0':'L':_ -> HT.status403 -- invalid grantor '0':'P':_ -> HT.status403 -- invalid role specification - "23503" -> HT.status409 -- foreign_key_violation - "23505" -> HT.status409 -- unique_violation + "23503" -> HT.status409 -- foreign_key_violation + "23505" -> HT.status409 -- unique_violation '2':'5':_ -> HT.status500 -- invalid tx state '2':'8':_ -> HT.status403 -- invalid auth specification '2':'D':_ -> HT.status500 -- invalid tx termination @@ -76,8 +87,8 @@ httpStatus (H.ResultError (H.ServerError c _ _ _)) = 'H':'V':_ -> HT.status500 -- foreign data wrapper error 'P':'0':_ -> HT.status500 -- PL/pgSQL Error 'X':'X':_ -> HT.status500 -- internal Error - "42P01" -> HT.status404 -- undefined table - "42501" -> HT.status404 -- insufficient privilege - _ -> HT.status400 -httpStatus (H.ResultError _) = HT.status500 -httpStatus (H.ClientError _) = HT.status503 + "42P01" -> HT.status404 -- undefined table + "42501" -> HT.status404 -- insufficient privilege + _ -> HT.status400 +httpStatus (P.SessionError (H.ResultError _)) = HT.status500 +httpStatus (P.SessionError (H.ClientError _)) = HT.status503 diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index fd1489b07..323190b0e 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -module Main where +module PostgREST.Main where import PostgREST.App @@ -9,21 +9,20 @@ import PostgREST.Config (AppConfig (..), prettyVersion, readOptions) import PostgREST.DbStructure -import PostgREST.Error (errResponse, pgErrResponse) +import PostgREST.Error (pgErrResponse) import PostgREST.Middleware +import PostgREST.Types (DbStructure) import PostgREST.QueryBuilder (inTransaction, Isolation(..)) import Control.Monad import Data.Monoid ((<>)) -import Data.Pool import Data.String.Conversions (cs) import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Hasql.Query as H -import qualified Hasql.Connection as H import qualified Hasql.Session as H import qualified Hasql.Decoders as HD import qualified Hasql.Encoders as HE -import qualified Network.HTTP.Types.Status as HT +import qualified Hasql.Pool as P import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Middleware.RequestLogger (logStdout) @@ -55,51 +54,45 @@ main = do conf <- readOptions let port = configPort conf + pgSettings = cs (configDatabase conf) + appSettings = setPort port + . setServerName (cs $ "postgrest/" <> prettyVersion) + $ defaultSettings unless (secret "secret" /= configJwtSecret conf) $ putStrLn "WARNING, running in insecure mode, JWT secret is the default value" Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) - let pgSettings = cs (configDatabase conf) - appSettings = setPort port - . setServerName (cs $ "postgrest/" <> prettyVersion) - $ defaultSettings - middle = logStdout . defaultMiddle - pool <- createPool (H.acquire pgSettings) - (either (const $ return ()) H.release) 1 1 (configPool conf) - - dbStructure <- withResource pool $ \case - Left err -> error $ show err - Right c -> do - supported <- H.run isServerVersionSupported c - case supported of - Left e -> error $ show e - Right good -> unless good $ - error ( - "Cannot run in this PostgreSQL version, PostgREST needs at least " - <> show minimumPgVersion) - - dbOrError <- H.run (getDbStructure (cs $ configSchema conf)) c - either (error . show) return dbOrError + pool <- P.acquire (configPool conf, 10, pgSettings) #ifndef mingw32_HOST_OS tid <- myThreadId void $ installHandler keyboardSignal (Catch $ do - destroyAllResources pool + P.release pool throwTo tid UserInterrupt ) Nothing #endif - runSettings appSettings $ middle $ \ req respond -> do + result <- P.use pool $ do + supported <- isServerVersionSupported + unless supported $ error ( + "Cannot run in this PostgreSQL version, PostgREST needs at least " + <> show minimumPgVersion) + getDbStructure (cs $ configSchema conf) + + let dbStructure = either (error.show) id result + runSettings appSettings $ postgrest conf dbStructure pool + +postgrest :: AppConfig -> DbStructure -> P.Pool -> Application +postgrest conf dbStructure pool = + let middle = logStdout . defaultMiddle in + + middle $ \ req respond -> do time <- getPOSIXTime body <- strictRequestBody req - let handleReq = H.run $ inTransaction ReadCommitted - (runWithClaims conf time (app dbStructure conf body) req) - res <- withResource pool $ \case - Left err -> return $ errResponse HT.status500 (cs . show $ err) - Right c -> do - resOrError <- handleReq c - return $ either pgErrResponse id resOrError - respond res + let handleReq = inTransaction ReadCommitted $ + runWithClaims conf time (app dbStructure conf body) req + resp <- either pgErrResponse id <$> P.use pool handleReq + respond resp diff --git a/stack.yaml b/stack.yaml index 1774ffffa..37cc16c1c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,7 @@ resolver: lts-5.0 extra-deps: - hasql-0.19.3.3 + - hasql-pool-0.4 - Ranged-sets-0.3.0 - packdeps-0.4.2.1 ghc-options: diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index f678ae269..3ae39724f 100644 --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -5,15 +5,13 @@ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.HTTP.Types -import qualified Hasql.Connection as H import SpecHelper -import PostgREST.Types (DbStructure(..)) +import Network.Wai (Application) -- }}} -spec :: DbStructure -> H.Connection -> Spec -spec struct c = around (withApp cfgDefault struct c) - $ describe "authorization" $ do +spec :: SpecWith Application +spec = describe "authorization" $ do it "hides tables that anonymous does not own" $ get "/authors_only" `shouldRespondWith` 404 diff --git a/test/Feature/ConcurrentSpec.hs b/test/Feature/ConcurrentSpec.hs index 7fd60d354..044d3020f 100644 --- a/test/Feature/ConcurrentSpec.hs +++ b/test/Feature/ConcurrentSpec.hs @@ -13,14 +13,11 @@ import Test.Hspec.Wai.Internal import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.Wai.Test (Session) -import qualified Hasql.Connection as H -import SpecHelper -import PostgREST.Types (DbStructure(..)) - -spec :: DbStructure -> H.Connection -> Spec -spec struct c = around (withApp cfgDefault struct c) $ +import Network.Wai (Application) +spec :: SpecWith Application +spec = describe "Queryiny in parallel" $ it "should not raise 'transaction in progress' error" $ raceTest 3 $ diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs index 811af712a..c639f7309 100644 --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -5,16 +5,16 @@ import Test.Hspec import Test.Hspec.Wai import Network.Wai.Test (SResponse(simpleHeaders, simpleBody)) import qualified Data.ByteString.Lazy as BL -import qualified Hasql.Connection as H import SpecHelper -import PostgREST.Types (DbStructure(..)) import Network.HTTP.Types +import Network.Wai (Application) -- }}} -spec :: DbStructure -> H.Connection -> Spec -spec struct c = around (withApp cfgDefault struct c) $ describe "CORS" $ do +spec :: SpecWith Application +spec = + describe "CORS" $ do let preflightHeaders = [ ("Accept", "*/*"), ("Origin", "http://example.com"), diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs index ba9c60eea..76d1fcc64 100644 --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -4,15 +4,11 @@ import Test.Hspec import Test.Hspec.Wai import Text.Heredoc -import SpecHelper -import PostgREST.Types (DbStructure(..)) -import qualified Hasql.Connection as H - import Network.HTTP.Types +import Network.Wai (Application) -spec :: DbStructure -> H.Connection -> Spec -spec struct c = beforeAll resetDb - . around (withApp cfgDefault struct c) $ +spec :: SpecWith Application +spec = describe "Deleting" $ do context "existing record" $ do it "succeeds with 204 and deletion count" $ diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index e3030fe5a..7b3d41bde 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -6,7 +6,6 @@ import Test.Hspec.Wai.JSON import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus)) import SpecHelper -import PostgREST.Types (DbStructure(..)) import qualified Data.Aeson as JSON import Data.Maybe (fromJust) @@ -14,12 +13,12 @@ import Text.Heredoc import Network.HTTP.Types.Header import Network.HTTP.Types import Control.Monad (replicateM_) -import qualified Hasql.Connection as H import TestTypes(IncPK(..), CompoundPK(..)) +import Network.Wai (Application) -spec :: DbStructure -> H.Connection -> Spec -spec struct c = beforeAll_ resetDb $ around (withApp cfgDefault struct c) $ do +spec :: SpecWith Application +spec = do describe "Posting new record" $ do context "disparate json types" $ do it "accepts disparate json types" $ do diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs index 71e6aa714..95d8b9223 100644 --- a/test/Feature/QueryLimitedSpec.hs +++ b/test/Feature/QueryLimitedSpec.hs @@ -5,15 +5,12 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.HTTP.Types import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus)) -import qualified Hasql.Connection as H import SpecHelper -import PostgREST.Types (DbStructure(..)) +import Network.Wai (Application) -spec :: DbStructure -> H.Connection -> Spec -spec struct c = - beforeAll resetDb - . around (withApp (cfgLimitRows 3) struct c) $ +spec :: SpecWith Application +spec = describe "Requesting many items with server limits enabled" $ do it "restricts results" $ get "/items" diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 3c3062db2..6ae4194e7 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -5,14 +5,13 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.HTTP.Types import Network.Wai.Test (SResponse(simpleHeaders)) -import qualified Hasql.Connection as H import SpecHelper -import PostgREST.Types (DbStructure(..)) import Text.Heredoc +import Network.Wai (Application) -spec :: DbStructure -> H.Connection -> Spec -spec struct c = around (withApp cfgDefault struct c) $ do +spec :: SpecWith Application +spec = do describe "Querying a table with a column called count" $ it "should not confuse count column with pg_catalog.count aggregate" $ diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs index 0ab998712..1b20c8d5a 100644 --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -5,14 +5,13 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.HTTP.Types import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus)) -import qualified Hasql.Connection as H import SpecHelper -import PostgREST.Types (DbStructure(..)) +import Network.Wai (Application) + +spec :: SpecWith Application +spec = -spec :: DbStructure -> H.Connection -> Spec -spec struct c = beforeAll resetDb - . around (withApp cfgDefault struct c) $ describe "GET /items" $ do context "without range headers" $ do diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index a441f00c9..3ab2ac82b 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -3,15 +3,15 @@ module Feature.StructureSpec where import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import qualified Hasql.Connection as H import SpecHelper -import PostgREST.Types (DbStructure(..)) import Network.HTTP.Types +import Network.Wai (Application) + +spec :: SpecWith Application +spec = do -spec :: DbStructure -> H.Connection -> Spec -spec struct c = around (withApp cfgDefault struct c) $ do describe "GET /" $ do it "lists views in schema" $ request methodGet "/" [] "" diff --git a/test/Main.hs b/test/Main.hs index b7d115b92..3d462e577 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -3,10 +3,10 @@ module Main where import Test.Hspec import SpecHelper -import qualified Hasql.Session as H -import qualified Hasql.Connection as H +import qualified Hasql.Pool as P import PostgREST.DbStructure (getDbStructure) +import PostgREST.Main (postgrest) import Data.String.Conversions (cs) import qualified Feature.AuthSpec @@ -23,23 +23,23 @@ main :: IO () main = do setupDb - H.acquire (cs dbString) >>= \case - Left err -> error $ show err - Right c -> do - dbOrErr <- H.run (getDbStructure "test") c - -- Not using hspec-discover because we want to precompute - -- the db structure and pass it to specs for speed - either (error.show) (hspec . specs c) dbOrErr - H.release c + pool <- P.acquire (10, 10, cs dbString) + + result <- P.use pool $ getDbStructure "test" + let dbStructure = either (error.show) id result + withApp = ($ postgrest cfgDefault dbStructure pool) + + hspec . sequence_ . map (around withApp) $ specs where - specs conn dbStructure = do - describe "Feature.AuthSpec" $ Feature.AuthSpec.spec dbStructure conn - describe "Feature.ConcurrentSpec" $ Feature.ConcurrentSpec.spec dbStructure conn - describe "Feature.CorsSpec" $ Feature.CorsSpec.spec dbStructure conn - describe "Feature.DeleteSpec" $ Feature.DeleteSpec.spec dbStructure conn - describe "Feature.InsertSpec" $ Feature.InsertSpec.spec dbStructure conn - describe "Feature.QueryLimitedSpec" $ Feature.QueryLimitedSpec.spec dbStructure conn - describe "Feature.QuerySpec" $ Feature.QuerySpec.spec dbStructure conn - describe "Feature.RangeSpec" $ Feature.RangeSpec.spec dbStructure conn - describe "Feature.StructureSpec" $ Feature.StructureSpec.spec dbStructure conn + specs = map (uncurry describe) [ + ("Feature.AuthSpec" , Feature.AuthSpec.spec) + , ("Feature.ConcurrentSpec" , Feature.ConcurrentSpec.spec) + , ("Feature.CorsSpec" , Feature.CorsSpec.spec) + , ("Feature.DeleteSpec" , Feature.DeleteSpec.spec) + , ("Feature.InsertSpec" , Feature.InsertSpec.spec) + , ("Feature.QueryLimitedSpec" , Feature.QueryLimitedSpec.spec) + , ("Feature.QuerySpec" , Feature.QuerySpec.spec) + , ("Feature.RangeSpec" , Feature.RangeSpec.spec) + , ("Feature.StructureSpec" , Feature.StructureSpec.spec) + ] diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 22b80ee3c..db386d3f3 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -1,10 +1,6 @@ module SpecHelper where -import Network.Wai -import Test.Hspec - import Data.String.Conversions (cs) -import Data.Time.Clock.POSIX (getPOSIXTime) import Control.Monad (void) import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, @@ -16,15 +12,7 @@ import qualified Data.ByteString.Char8 as BS import System.Process (readProcess) import Web.JWT (secret) -import qualified Hasql.Connection as H -import qualified Hasql.Session as H - -import PostgREST.App (app) import PostgREST.Config (AppConfig(..)) -import PostgREST.Middleware -import PostgREST.Error(pgErrResponse) -import PostgREST.Types -import PostgREST.QueryBuilder (inTransaction, Isolation(..)) dbString :: String dbString = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test" @@ -38,21 +26,6 @@ cfgDefault = cfg dbString Nothing cfgLimitRows :: Integer -> AppConfig cfgLimitRows = cfg dbString . Just -withApp :: AppConfig -> DbStructure -> H.Connection - -> ActionWith Application -> IO () -withApp config dbStructure c perform = - perform $ defaultMiddle $ \req resp -> do - time <- getPOSIXTime - body <- strictRequestBody req - let handleReq = H.run $ inTransaction ReadCommitted - (runWithClaims config time (app dbStructure config body) req) - - handleReq c >>= \case - Left err -> do - void $ H.run (H.sql "rollback;") c - resp $ pgErrResponse err - Right res -> resp res - setupDb :: IO () setupDb = do void $ readProcess "psql" ["-d", "postgres", "-a", "-f", "test/fixtures/database.sql"] [] From 30e5032ade49885ee6b963f915fe692ec53cf513 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 21 Feb 2016 14:11:46 -0800 Subject: [PATCH 06/18] Use lower optimization to speed up regular dev builds --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 37cc16c1c..e88e4a6de 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,7 +5,7 @@ extra-deps: - Ranged-sets-0.3.0 - packdeps-0.4.2.1 ghc-options: - postgrest: -O2 -Werror -Wall -fwarn-monomorphism-restriction -fwarn-missing-exported-sigs -fwarn-identities + postgrest: -O1 -Werror -Wall -fwarn-monomorphism-restriction -fwarn-missing-exported-sigs -fwarn-identities packages: - '.' From d5c1438c6e3e2b6367e8db2ab114167a5ba3c93d Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 21 Feb 2016 18:05:25 -0800 Subject: [PATCH 07/18] Use hasql-transaction Also use hspec before-wrapper --- postgrest.cabal | 3 +++ src/PostgREST/App.hs | 4 ++-- src/PostgREST/Main.hs | 9 +++++---- src/PostgREST/Middleware.hs | 6 +++--- src/PostgREST/QueryBuilder.hs | 20 -------------------- stack.yaml | 3 +++ test/Main.hs | 4 ++-- 7 files changed, 18 insertions(+), 31 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 81b62457b..c4a289da4 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -36,6 +36,7 @@ executable postgrest , errors , hasql >= 0.19.3.3 && < 0.20 , hasql-pool >= 0.4 && < 0.5 + , hasql-transaction >= 0.4 && < 0.5 , http-types , interpolatedstring-perl6 , jwt @@ -86,6 +87,7 @@ library , contravariant , errors , hasql + , hasql-transaction , hasql-pool , http-types , interpolatedstring-perl6 @@ -162,6 +164,7 @@ Test-Suite spec , errors , hasql , hasql-pool + , hasql-transaction , heredoc , hspec == 2.2.* , hspec-wai diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 418a84f55..000d66544 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -31,7 +31,7 @@ import Data.Aeson import Data.Aeson.Types (emptyArray) import Data.Monoid import qualified Data.Vector as V -import qualified Hasql.Session as H +import qualified Hasql.Transaction as H import PostgREST.Config (AppConfig (..)) import PostgREST.Parsers @@ -58,7 +58,7 @@ import PostgREST.QueryBuilder ( callProc import Prelude -app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Session Response +app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Transaction Response app dbStructure conf reqBody req = let -- TODO: blow up for Left values (there is a middleware that checks the headers) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 323190b0e..1200aea5e 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -12,7 +12,6 @@ import PostgREST.DbStructure import PostgREST.Error (pgErrResponse) import PostgREST.Middleware import PostgREST.Types (DbStructure) -import PostgREST.QueryBuilder (inTransaction, Isolation(..)) import Control.Monad import Data.Monoid ((<>)) @@ -20,6 +19,7 @@ import Data.String.Conversions (cs) import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Hasql.Query as H import qualified Hasql.Session as H +import qualified Hasql.Transaction as HT import qualified Hasql.Decoders as HD import qualified Hasql.Encoders as HE import qualified Hasql.Pool as P @@ -92,7 +92,8 @@ postgrest conf dbStructure pool = middle $ \ req respond -> do time <- getPOSIXTime body <- strictRequestBody req - let handleReq = inTransaction ReadCommitted $ - runWithClaims conf time (app dbStructure conf body) req - resp <- either pgErrResponse id <$> P.use pool handleReq + + let handleReq = runWithClaims conf time (app dbStructure conf body) req + resp <- either pgErrResponse id <$> P.use pool + (HT.run handleReq HT.ReadCommitted HT.Write) respond resp diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 4292e261c..e68ddbc6f 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -7,7 +7,7 @@ import Data.Maybe (fromMaybe) import Data.Text import Data.String.Conversions (cs) import Data.Time.Clock (NominalDiffTime) -import qualified Hasql.Session as H +import qualified Hasql.Transaction as H import Network.HTTP.Types.Header (hAccept, hAuthorization) import Network.HTTP.Types.Status (status415, status400) @@ -27,8 +27,8 @@ import Prelude hiding(concat) import qualified Data.Map.Lazy as M runWithClaims :: AppConfig -> NominalDiffTime -> - (Request -> H.Session Response) -> - Request -> H.Session Response + (Request -> H.Transaction Response) -> + Request -> H.Transaction Response runWithClaims conf time app req = do H.sql setAnon case split (== ' ') (cs auth) of diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 0da811869..046040909 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -18,7 +18,6 @@ module PostgREST.QueryBuilder ( , callProc , createReadStatement , createWriteStatement - , inTransaction , operators , pgFmtIdent , pgFmtLit @@ -27,11 +26,9 @@ module PostgREST.QueryBuilder ( , sourceCTEName , unquoted , ResultsWithCount - , Isolation(..) ) where import qualified Hasql.Query as H -import qualified Hasql.Session as H import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD @@ -504,20 +501,3 @@ pgFmtAsJsonPath (Just xx) = " AS " <> last xx trimNullChars :: Text -> Text trimNullChars = T.takeWhile (/= '\x0') - -data Isolation = ReadCommitted | RepeatableRead | Serializable - -{- | - Wrap a session in a transaction of desired isolation level --} -inTransaction :: Isolation -> H.Session a -> H.Session a -inTransaction lvl f = do - H.sql $ "begin " <> isolate <> ";" - r <- f - H.sql "commit;" - return r - where - isolate = case lvl of - ReadCommitted -> "ISOLATION LEVEL READ COMMITTED" - RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ" - Serializable -> "ISOLATION LEVEL SERIALIZABLE" diff --git a/stack.yaml b/stack.yaml index e88e4a6de..4bfc24c5e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,8 +2,11 @@ resolver: lts-5.0 extra-deps: - hasql-0.19.3.3 - hasql-pool-0.4 + - hasql-transaction-0.4.2 - Ranged-sets-0.3.0 - packdeps-0.4.2.1 + - bytestring-tree-builder-0.2.5 + - postgresql-error-codes-1 ghc-options: postgrest: -O1 -Werror -Wall -fwarn-monomorphism-restriction -fwarn-missing-exported-sigs -fwarn-identities diff --git a/test/Main.hs b/test/Main.hs index 3d462e577..f3e9f91e1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -27,9 +27,9 @@ main = do result <- P.use pool $ getDbStructure "test" let dbStructure = either (error.show) id result - withApp = ($ postgrest cfgDefault dbStructure pool) + withApp = return $ postgrest cfgDefault dbStructure pool - hspec . sequence_ . map (around withApp) $ specs + hspec . sequence_ . map (before withApp) $ specs where specs = map (uncurry describe) [ From 072a6ce4c74b171dece71871040646d085c08ae5 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 21 Feb 2016 18:37:17 -0800 Subject: [PATCH 08/18] Bump hasql to 0.19.8 --- stack.yaml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/stack.yaml b/stack.yaml index 4bfc24c5e..b982cdd49 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,12 +1,13 @@ resolver: lts-5.0 extra-deps: - - hasql-0.19.3.3 + - Ranged-sets-0.3.0 + - bytestring-tree-builder-0.2.5 + - hasql-0.19.8 - hasql-pool-0.4 - hasql-transaction-0.4.2 - - Ranged-sets-0.3.0 - packdeps-0.4.2.1 - - bytestring-tree-builder-0.2.5 - postgresql-error-codes-1 + - postgresql-binary-0.8.1 ghc-options: postgrest: -O1 -Werror -Wall -fwarn-monomorphism-restriction -fwarn-missing-exported-sigs -fwarn-identities From 7b7babd1d1d00dfdaccfbf65441ce66a2c2bd53f Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 22 Feb 2016 08:41:31 -0800 Subject: [PATCH 09/18] Fix frozen tests Problem found by @ruslantalpa --- src/PostgREST/Error.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 03aa8523d..e7893aa0b 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -30,7 +30,7 @@ instance JSON.ToJSON P.UsageError where "code" .= ("" :: T.Text), "message" .= ("Connection error" :: T.Text), "details" .= (cs (fromMaybe "" e) :: T.Text)] - toJSON e = JSON.toJSON e -- H.Error + toJSON (P.SessionError e) = JSON.toJSON e -- H.Error instance JSON.ToJSON H.Error where toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [ From d4a4bbf9667634d0ba4cb60585b05c502b20478f Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 22 Feb 2016 16:52:50 -0800 Subject: [PATCH 10/18] Roll back on db errors --- postgrest.cabal | 3 +++ src/PostgREST/Main.hs | 7 ++++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/postgrest.cabal b/postgrest.cabal index c4a289da4..21e51016e 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -40,6 +40,7 @@ executable postgrest , http-types , interpolatedstring-perl6 , jwt + , mtl , optparse-applicative >= 0.11 && < 0.13 , parsec , postgrest @@ -92,6 +93,7 @@ library , http-types , interpolatedstring-perl6 , jwt + , mtl , optparse-applicative , parsec , regex-tdfa @@ -173,6 +175,7 @@ Test-Suite spec , interpolatedstring-perl6 , jwt , monad-control + , mtl , optparse-applicative , parsec , process diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 1200aea5e..c8931da2a 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -14,6 +14,7 @@ import PostgREST.Middleware import PostgREST.Types (DbStructure) import Control.Monad +import Control.Monad.Error.Class (catchError, throwError) import Data.Monoid ((<>)) import Data.String.Conversions (cs) import Data.Time.Clock.POSIX (getPOSIXTime) @@ -95,5 +96,9 @@ postgrest conf dbStructure pool = let handleReq = runWithClaims conf time (app dbStructure conf body) req resp <- either pgErrResponse id <$> P.use pool - (HT.run handleReq HT.ReadCommitted HT.Write) + (rollbackOnError $ HT.run handleReq HT.ReadCommitted HT.Write) respond resp + + where + rollbackOnError :: H.Session a -> H.Session a + rollbackOnError = (`catchError` ((H.sql "rollback;" >>) . throwError)) From 17acd134c7df076ed578eb45262eade4a5f262a0 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 22 Feb 2016 17:48:33 -0800 Subject: [PATCH 11/18] Suppress server logging in test mode --- src/PostgREST/Config.hs | 2 ++ src/PostgREST/Main.hs | 2 +- test/Main.hs | 4 ++-- test/SpecHelper.hs | 15 +++++---------- 4 files changed, 10 insertions(+), 13 deletions(-) diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 5aaccf9a7..5cddcec12 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -43,6 +43,7 @@ data AppConfig = AppConfig { , configJwtSecret :: Secret , configPool :: Int , configMaxRows :: Maybe Integer + , configQuiet :: Bool } argParser :: Parser AppConfig @@ -55,6 +56,7 @@ argParser = AppConfig strOption (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault)) <*> option auto (long "pool" <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault) <*> (readMay <$> strOption (long "max-rows" <> short 'm' <> help "max rows in response" <> metavar "COUNT" <> value "infinity" <> showDefault)) + <*> pure False defaultCorsPolicy :: CorsResourcePolicy defaultCorsPolicy = CorsResourcePolicy Nothing diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index c8931da2a..98efe5f19 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -88,7 +88,7 @@ main = do postgrest :: AppConfig -> DbStructure -> P.Pool -> Application postgrest conf dbStructure pool = - let middle = logStdout . defaultMiddle in + let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in middle $ \ req respond -> do time <- getPOSIXTime diff --git a/test/Main.hs b/test/Main.hs index f3e9f91e1..01416a100 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -23,11 +23,11 @@ main :: IO () main = do setupDb - pool <- P.acquire (10, 10, cs dbString) + pool <- P.acquire (10, 10, cs testDbConn) result <- P.use pool $ getDbStructure "test" let dbStructure = either (error.show) id result - withApp = return $ postgrest cfgDefault dbStructure pool + withApp = return $ postgrest testCfg dbStructure pool hspec . sequence_ . map (before withApp) $ specs diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index db386d3f3..be8a9e94f 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -14,17 +14,12 @@ import Web.JWT (secret) import PostgREST.Config (AppConfig(..)) -dbString :: String -dbString = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test" +testDbConn :: String +testDbConn = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test" -cfg :: String -> Maybe Integer -> AppConfig -cfg conStr = AppConfig conStr "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 - -cfgDefault :: AppConfig -cfgDefault = cfg dbString Nothing - -cfgLimitRows :: Integer -> AppConfig -cfgLimitRows = cfg dbString . Just +testCfg :: AppConfig +testCfg = + AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 Nothing True setupDb :: IO () setupDb = do From b0974a4e36f41a443957fb20f042bde9679301aa Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 22 Feb 2016 17:50:00 -0800 Subject: [PATCH 12/18] Reset db between each test suite --- test/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Main.hs b/test/Main.hs index 01416a100..c4abe2177 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -29,7 +29,7 @@ main = do let dbStructure = either (error.show) id result withApp = return $ postgrest testCfg dbStructure pool - hspec . sequence_ . map (before withApp) $ specs + hspec . mapM_ (beforeAll_ resetDb . before withApp) $ specs where specs = map (uncurry describe) [ From c02dd4aa984fe9b298b3a90d32480ba8163a89c1 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 22 Feb 2016 17:53:10 -0800 Subject: [PATCH 13/18] Enable real threads in test --- postgrest.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/postgrest.cabal b/postgrest.cabal index 21e51016e..406f6184b 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -129,6 +129,7 @@ Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes + ghc-options: -threaded -rtsopts -with-rtsopts=-N Hs-Source-Dirs: test, src Main-Is: Main.hs Other-Modules: Feature.AuthSpec From c28b26d949da21a2510430e2c7826640a749c2ae Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 22 Feb 2016 19:13:07 -0800 Subject: [PATCH 14/18] Run QueryLimitedSpec with its own server flags --- test/Main.hs | 9 +++++++-- test/SpecHelper.hs | 4 ++++ 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index c4abe2177..918b8680d 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -28,8 +28,14 @@ main = do result <- P.use pool $ getDbStructure "test" let dbStructure = either (error.show) id result withApp = return $ postgrest testCfg dbStructure pool + ltdApp = return $ postgrest testLtdRowsCfg dbStructure pool - hspec . mapM_ (beforeAll_ resetDb . before withApp) $ specs + hspec $ do + mapM_ (beforeAll_ resetDb . before withApp) specs + + -- this test runs with a different server flag + beforeAll_ resetDb . before ltdApp $ + describe "Feature.QueryLimitedSpec" Feature.QueryLimitedSpec.spec where specs = map (uncurry describe) [ @@ -38,7 +44,6 @@ main = do , ("Feature.CorsSpec" , Feature.CorsSpec.spec) , ("Feature.DeleteSpec" , Feature.DeleteSpec.spec) , ("Feature.InsertSpec" , Feature.InsertSpec.spec) - , ("Feature.QueryLimitedSpec" , Feature.QueryLimitedSpec.spec) , ("Feature.QuerySpec" , Feature.QuerySpec.spec) , ("Feature.RangeSpec" , Feature.RangeSpec.spec) , ("Feature.StructureSpec" , Feature.StructureSpec.spec) diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index be8a9e94f..87abae532 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -21,6 +21,10 @@ testCfg :: AppConfig testCfg = AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 Nothing True +testLtdRowsCfg :: AppConfig +testLtdRowsCfg = + AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 3) True + setupDb :: IO () setupDb = do void $ readProcess "psql" ["-d", "postgres", "-a", "-f", "test/fixtures/database.sql"] [] From de772b92467abe79a4e6719529d4c47920b46eda Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 22 Feb 2016 20:58:44 -0800 Subject: [PATCH 15/18] Modified the concurrent test to illustrate problem with prepared statement --- test/Feature/ConcurrentSpec.hs | 2 +- test/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Feature/ConcurrentSpec.hs b/test/Feature/ConcurrentSpec.hs index 044d3020f..be154375d 100644 --- a/test/Feature/ConcurrentSpec.hs +++ b/test/Feature/ConcurrentSpec.hs @@ -20,7 +20,7 @@ spec :: SpecWith Application spec = describe "Queryiny in parallel" $ it "should not raise 'transaction in progress' error" $ - raceTest 3 $ + raceTest 10 $ get "/fakefake" `shouldRespondWith` ResponseMatcher { matchBody = Just [json| diff --git a/test/Main.hs b/test/Main.hs index 918b8680d..cc52c0fb4 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -23,7 +23,7 @@ main :: IO () main = do setupDb - pool <- P.acquire (10, 10, cs testDbConn) + pool <- P.acquire (3, 10, cs testDbConn) result <- P.use pool $ getDbStructure "test" let dbStructure = either (error.show) id result From f28b03f419086e59db107350d8881de1f3b735e8 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 25 Feb 2016 20:13:03 -0800 Subject: [PATCH 16/18] Allow new hasql-transaction to do rollbacks --- postgrest.cabal | 2 +- src/PostgREST/Main.hs | 7 +------ stack.yaml | 2 +- 3 files changed, 3 insertions(+), 8 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 406f6184b..af14992f3 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -36,7 +36,7 @@ executable postgrest , errors , hasql >= 0.19.3.3 && < 0.20 , hasql-pool >= 0.4 && < 0.5 - , hasql-transaction >= 0.4 && < 0.5 + , hasql-transaction >= 0.4.3 && < 0.5 , http-types , interpolatedstring-perl6 , jwt diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 98efe5f19..ae840249d 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -14,7 +14,6 @@ import PostgREST.Middleware import PostgREST.Types (DbStructure) import Control.Monad -import Control.Monad.Error.Class (catchError, throwError) import Data.Monoid ((<>)) import Data.String.Conversions (cs) import Data.Time.Clock.POSIX (getPOSIXTime) @@ -96,9 +95,5 @@ postgrest conf dbStructure pool = let handleReq = runWithClaims conf time (app dbStructure conf body) req resp <- either pgErrResponse id <$> P.use pool - (rollbackOnError $ HT.run handleReq HT.ReadCommitted HT.Write) + (HT.run handleReq HT.ReadCommitted HT.Write) respond resp - - where - rollbackOnError :: H.Session a -> H.Session a - rollbackOnError = (`catchError` ((H.sql "rollback;" >>) . throwError)) diff --git a/stack.yaml b/stack.yaml index b982cdd49..250e65033 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,7 @@ extra-deps: - bytestring-tree-builder-0.2.5 - hasql-0.19.8 - hasql-pool-0.4 - - hasql-transaction-0.4.2 + - hasql-transaction-0.4.3 - packdeps-0.4.2.1 - postgresql-error-codes-1 - postgresql-binary-0.8.1 From 7ba5363d25c4a1cd1d437f3b7aaa06b4d5be8b2e Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 26 Feb 2016 08:18:47 -0800 Subject: [PATCH 17/18] Upgrade hasql to fix prepared statement problem --- postgrest.cabal | 2 +- stack.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index af14992f3..9fdb9cda3 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -34,7 +34,7 @@ executable postgrest , containers , contravariant , errors - , hasql >= 0.19.3.3 && < 0.20 + , hasql >= 0.19.9 && < 0.20 , hasql-pool >= 0.4 && < 0.5 , hasql-transaction >= 0.4.3 && < 0.5 , http-types diff --git a/stack.yaml b/stack.yaml index 250e65033..74f1079af 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,7 +2,7 @@ resolver: lts-5.0 extra-deps: - Ranged-sets-0.3.0 - bytestring-tree-builder-0.2.5 - - hasql-0.19.8 + - hasql-0.19.9 - hasql-pool-0.4 - hasql-transaction-0.4.3 - packdeps-0.4.2.1 From d466ea45ffbf0ede85aecd54018b4447ffde7b7c Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 26 Feb 2016 10:06:54 -0800 Subject: [PATCH 18/18] Add changelog entry Nice work guys, this took a lot of cooperation --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1fb97db65..9f901f0fa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,8 @@ This project adheres to [Semantic Versioning](http://semver.org/). ### Fixed +- Prevent query error from infecting later connection - @begriffs, @ruslantalpa, @nikita-volkov, @jwiegley + ## [0.3.0.4] - 2016-02-12 ### Fixed