Merge pull request #508 from begriffs/test-plain-build

Test that binary builds, not just that suite passes

CHANGELOG.md

@@ -7,6 +7,14 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ### Fixed
 
+## [0.3.1.0] - 2016-02-28
+
+### Fixed
+- Prevent query error from infecting later connection - @begriffs, @ruslantalpa, @nikita-volkov, @jwiegley
+
+### Added
+- Applies range headers to RPC calls - @diogob
+
 ## [0.3.0.4] - 2016-02-12
 
 ### Fixed

app.json

@@ -10,7 +10,7 @@
     },
     "POSTGREST_VER": {
       "description": "Version of PostgREST to deploy",
-      "value": "0.3.0.4"
+      "value": "0.3.1.0"
     },
     "DB_NAME": {
       "description": "Database name",

circle.yml

@@ -9,13 +9,17 @@ dependencies:
     - createdb -O postgrest_test -U ubuntu postgrest_test
   override:
     - stack setup
+    - rm -fr $(stack path --dist-dir) $(stack path --local-install-root)
     - stack install hlint packdeps cabal-install
+    - stack build
     - stack build --test --no-run-tests
 
 test:
   override:
     - stack test
     - git ls-files | grep '\.l\?hs$' | xargs stack exec -- hlint -X QuasiQuotes "$@"
+    - stack exec -- cabal update
+    - stack exec --no-ghc-package-path -- cabal install --only-d --dry-run
     - stack exec -- packdeps *.cabal || true
     - stack exec -- cabal check
     - stack haddock --no-haddock-deps

postgrest.cabal

@@ -2,7 +2,7 @@ name:                  postgrest
 description:           Reads the schema of a PostgreSQL database and creates RESTful routes
                        for the tables and views, supporting all HTTP verbs that security
                        permits.
-version:               0.3.0.4
+version:               0.3.1.0
 synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
@@ -23,10 +23,10 @@ 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
+  build-depends:       aeson (>= 0.8 && < 0.10) || (>= 0.11 && < 0.12)
                      , base >= 4.8 && < 5
                      , bytestring
                      , case-insensitive
@@ -34,15 +34,17 @@ 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
                      , interpolatedstring-perl6
                      , jwt
+                     , mtl
                      , optparse-applicative >= 0.11 && < 0.13
                      , parsec
                      , postgrest
                      , regex-tdfa
-                     , resource-pool
                      , safe >= 0.3 && < 0.4
                      , scientific
                      , string-conversions
@@ -86,9 +88,12 @@ library
                      , contravariant
                      , errors
                      , hasql
+                     , hasql-transaction
+                     , hasql-pool
                      , http-types
                      , interpolatedstring-perl6
                      , jwt
+                     , mtl
                      , optparse-applicative
                      , parsec
                      , regex-tdfa
@@ -123,14 +128,17 @@ library
 Test-Suite spec
   Type:                exitcode-stdio-1.0
   Default-Language:    Haskell2010
-  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase
+  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
+                     , Feature.ConcurrentSpec
                      , Feature.CorsSpec
                      , Feature.DeleteSpec
                      , Feature.InsertSpec
                      , Feature.QuerySpec
+                     , Feature.QueryLimitedSpec
                      , Feature.RangeSpec
                      , Feature.StructureSpec
                      , Paths_postgrest
@@ -148,6 +156,7 @@ Test-Suite spec
                      , SpecHelper
                      , TestTypes
   Build-Depends:       aeson
+                     , async
                      , base
                      , base64-string
                      , bytestring
@@ -157,6 +166,8 @@ Test-Suite spec
                      , contravariant
                      , errors
                      , hasql
+                     , hasql-pool
+                     , hasql-transaction
                      , heredoc
                      , hspec == 2.2.*
                      , hspec-wai
@@ -164,6 +175,8 @@ Test-Suite spec
                      , http-types
                      , interpolatedstring-perl6
                      , jwt
+                     , monad-control
+                     , mtl
                      , optparse-applicative
                      , parsec
                      , process
@@ -173,11 +186,15 @@ Test-Suite spec
                      , string-conversions
                      , text
                      , time
+                     , transformers
+                     , transformers-base
                      , unordered-containers
+                     , unix
                      , vector
                      , wai
                      , wai-cors
                      , wai-extra
                      , wai-middleware-static
+                     , warp
                      , HTTP
                      , Ranged-sets

src/PostgREST/App.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE TupleSections #-}
 --module PostgREST.App where
 module PostgREST.App (
-  app
+  postgrest
 ) where
 
 import           Control.Applicative
@@ -18,6 +18,9 @@ import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text, replace, strip)
 import           Data.Tree
 
+import qualified Hasql.Pool                as P
+import qualified Hasql.Transaction         as HT
+
 import           Text.Parsec.Error
 import           Text.ParserCombinators.Parsec (parse)
 
@@ -26,25 +29,26 @@ import           Network.HTTP.Types.Header
 import           Network.HTTP.Types.Status
 import           Network.HTTP.Types.URI    (parseSimpleQuery)
 import           Network.Wai
+import           Network.Wai.Middleware.RequestLogger (logStdout)
 
 import           Data.Aeson
 import           Data.Aeson.Types (emptyArray)
 import           Data.Monoid
+import           Data.Time.Clock.POSIX     (getPOSIXTime)
 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
-import           PostgREST.DbStructure
-import           PostgREST.RangeQuery
 import           PostgREST.ApiRequest   (ApiRequest(..), ContentType(..)
                                             , Action(..), Target(..)
                                             , PreferRepresentation (..)
                                             , userApiRequest)
-import           PostgREST.Types
 import           PostgREST.Auth            (tokenJWT)
-import           PostgREST.Error           (errResponse)
+import           PostgREST.Config          (AppConfig (..))
-
+import           PostgREST.DbStructure
+import           PostgREST.Error           (errResponse, pgErrResponse)
+import           PostgREST.Parsers
+import           PostgREST.RangeQuery
+import           PostgREST.Middleware
 import           PostgREST.QueryBuilder ( callProc
                                         , addJoinConditions
                                         , sourceCTEName
@@ -55,10 +59,25 @@ import           PostgREST.QueryBuilder ( callProc
                                         , createWriteStatement
                                         , ResultsWithCount
                                         )
+import           PostgREST.Types
 
 import           Prelude
 
-app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Session Response
+
+postgrest :: AppConfig -> DbStructure -> P.Pool -> Application
+postgrest conf dbStructure pool =
+  let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in
+
+  middle $ \ req respond -> do
+    time <- getPOSIXTime
+    body <- strictRequestBody req
+
+    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
+
+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)
@@ -71,13 +90,10 @@ app dbStructure conf reqBody req =
       case readSqlParts of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (q, cq) -> do
-          let range = restrictRange (configMaxRows conf) $ iRange apiRequest
+          let singular = iPreferSingular apiRequest
-              singular = iPreferSingular apiRequest
               stm = createReadStatement q cq range singular
-                    (iPreferCount apiRequest) (contentType == TextCSV)
+                    shouldCount (contentType == TextCSV)
-          if range == emptyRange
+          respondToRange $ do
-          then return $ errResponse status416 "HTTP Range error"
-          else do
             row <- H.query () stm
             let (tableTotal, queryTotal, _ , body) = row
             if singular
@@ -85,10 +101,7 @@ app dbStructure conf reqBody req =
               then responseLBS status404 [] ""
               else responseLBS status200 [contentTypeH] (cs body)
             else do
-              let frm = rangeOffset range
+              let (status, contentRange) = rangeHeader queryTotal tableTotal
-                  to = frm + toInteger queryTotal - 1
-                  contentRange = contentRangeH frm to (toInteger <$> tableTotal)
-                  status = rangeStatus frm to (toInteger <$> tableTotal)
                   canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
                     . sortBy (comparing fst)
                     . map (join (***) cs)
@@ -165,14 +178,16 @@ app dbStructure conf reqBody req =
         then do
           let p = V.head payload
               jwtSecret = configJwtSecret conf
-
+          respondToRange $ do
-          bodyJson <- H.query () (callProc qi p)
+            row <- H.query () (callProc qi p range shouldCount)
-          returnJWT <- H.query qi doesProcReturnJWT
+            returnJWT <- H.query qi doesProcReturnJWT
-          return $ responseLBS status200 [jsonH]
+            let (tableTotal, queryTotal, body) = fromMaybe (Just 0, 0, emptyArray) row
-                 (let body = fromMaybe emptyArray bodyJson in
+                (status, contentRange) = rangeHeader queryTotal tableTotal
-                    if returnJWT
+              in
-                    then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
+              return $ responseLBS status [jsonH, contentRange]
-                    else cs $ encode body)
+                      (if returnJWT
+                      then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
+                      else cs $ encode body)
         else return notFound
 
     (ActionRead, TargetRoot, Nothing) -> do
@@ -196,6 +211,8 @@ app dbStructure conf reqBody req =
   allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
   schema = cs $ configSchema conf
   apiRequest = userApiRequest schema req reqBody
+  shouldCount = iPreferCount apiRequest
+  range = restrictRange (configMaxRows conf) $ iRange apiRequest
   readDbRequest = DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest
   mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest
   selectQuery = requestToQuery schema <$> readDbRequest
@@ -203,6 +220,14 @@ app dbStructure conf reqBody req =
   mutateQuery = requestToQuery schema <$> mutateDbRequest
   readSqlParts = (,) <$> selectQuery <*> countQuery
   mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
+  respondToRange response = if range == emptyRange
+                            then return $ errResponse status416 "HTTP Range error"
+                            else response
+  rangeHeader queryTotal tableTotal = let frm = rangeOffset range
+                                          to = frm + toInteger queryTotal - 1
+                                          contentRange = contentRangeH frm to (toInteger <$> tableTotal)
+                                          status = rangeStatus frm to (toInteger <$> tableTotal)
+                                      in (status, contentRange)
 
 rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
 rangeStatus _ _ Nothing = status200

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

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 (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 [
     "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 :: P.UsageError -> HT.Status
-httpStatus (H.ResultError (H.ServerError c _ _ _)) =
+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
+    "23503"   -> HT.status409 -- foreign_key_violation
-    "23505" -> HT.status409 -- unique_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
+    "42P01"   -> HT.status404 -- undefined table
-    "42501" -> HT.status404 -- insufficient privilege
+    "42501"   -> HT.status404 -- insufficient privilege
-    _ -> HT.status400
+    _         -> HT.status400
-httpStatus (H.ResultError _) = HT.status500
+httpStatus (P.SessionError (H.ResultError _)) = HT.status500
-httpStatus (H.ClientError _) = HT.status503
+httpStatus (P.SessionError (H.ClientError _)) = HT.status503

src/PostgREST/Main.hs

@@ -9,29 +9,20 @@ import           PostgREST.Config                     (AppConfig (..),
                                                        prettyVersion,
                                                        readOptions)
 import           PostgREST.DbStructure
-import           PostgREST.Error                      (errResponse, pgErrResponse)
-import           PostgREST.Middleware
-import           PostgREST.QueryBuilder               (inTransaction, Isolation(..))
 
-import           Control.Monad                        (unless, void)
+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)
 import           System.IO                            (BufferMode (..),
                                                        hSetBuffering, stderr,
                                                        stdin, stdout)
 import           Web.JWT                              (secret)
-
 #ifndef mingw32_HOST_OS
 import           System.Posix.Signals
 import           Control.Concurrent                   (myThreadId)
@@ -55,50 +46,32 @@ 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)
+  pool <- P.acquire (configPool conf, 10, pgSettings)
-      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
 
 #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
-    time <- getPOSIXTime
+    supported <- isServerVersionSupported
-    body <- strictRequestBody req
+    unless supported $ error (
-    let handleReq = H.run $ inTransaction ReadCommitted
+      "Cannot run in this PostgreSQL version, PostgREST needs at least "
-          (runWithClaims conf time (app dbStructure conf body) req)
+      <> show minimumPgVersion)
-    withResource pool $ \case
+    getDbStructure (cs $ configSchema conf)
-      Left err -> respond $ errResponse HT.status500 (cs . show $ err)
+
-      Right c -> do
+  let dbStructure = either (error.show) id result
-        resOrError <- handleReq c
+  runSettings appSettings $ postgrest conf dbStructure pool
-        either (respond . pgErrResponse) respond resOrError

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.Transaction Response) ->
-                 Request -> H.Session Response
+                 Request -> H.Transaction Response
 runWithClaims conf time app req = do
     H.sql setAnon
     case split (== ' ') (cs auth) of

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
 
@@ -206,18 +203,26 @@ addJoinConditions schema (Node (query, (n, r)) forest) =
     updatedForest = mapM (addJoinConditions schema) forest
     addCond query' con = query'{flt_=con ++ flt_ query'}
 
-callProc :: QualifiedIdentifier -> JSON.Object -> H.Query () (Maybe JSON.Value)
+type ProcResults = (Maybe Int64, Int64, JSON.Value)
-callProc qi params =
+callProc :: QualifiedIdentifier -> JSON.Object -> NonnegRange -> Bool -> H.Query () (Maybe ProcResults)
-  H.statement sql HE.unit decodeObj True
+callProc qi params range countTotal =
+  H.statement sql HE.unit decodeProc True
   where
-    sql = [qc| SELECT array_to_json(
+    sql = [qc| SELECT
+              {countQuery} as countTotal,
+              {countResult} as countResult,
+              array_to_json(
                 coalesce(array_agg(row_to_json(t)), '\{}')
               )::character varying
-              from ({_callSql}) t |]
+              from (select * {_callSql} {limitF range}) t |]
     _args = intercalate "," $ map _assignment (HM.toList params)
     _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
-    _callSql = [qc| select * from {fromQi qi}({_args}) |] :: BS.ByteString
+    _callSql = [qc| from {fromQi qi}({_args}) |] :: BS.ByteString
-    decodeObj = HD.maybeRow (HD.value HD.json)
+    countQuery = if countTotal then [qc| (select pg_catalog.count(1) {_callSql} c) |] else "null::bigint" :: BS.ByteString
+    countResult = "pg_catalog.count(t)" :: BS.ByteString
+    decodeProc = HD.maybeRow procRow
+    procRow = (,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
+                   <*> HD.value HD.json
 
 operators :: [(Text, SqlFragment)]
 operators = [
@@ -504,20 +509,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"

stack.yaml

@@ -1,10 +1,15 @@
-resolver: lts-5.0
+resolver: lts-5.5
 extra-deps:
-  - hasql-0.19.3.3
   - Ranged-sets-0.3.0
+  - bytestring-tree-builder-0.2.5
+  - hasql-0.19.9
+  - hasql-pool-0.4
+  - hasql-transaction-0.4.3
   - packdeps-0.4.2.1
+  - postgresql-error-codes-1
+  - postgresql-binary-0.8.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:
 - '.'

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 :: SpecWith Application
-spec struct c = around (withApp cfgDefault struct c)
+spec = describe "authorization" $ do
-  $ describe "authorization" $ do
 
   it "hides tables that anonymous does not own" $
     get "/authors_only" `shouldRespondWith` 404

test/Feature/ConcurrentSpec.hs

@@ -0,0 +1,51 @@
+{-# 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 Test.Hspec.Wai.JSON
+import Network.Wai.Test (Session)
+
+import Network.Wai (Application)
+
+spec :: SpecWith Application
+spec =
+  describe "Queryiny in parallel" $
+    it "should not raise 'transaction in progress' error" $
+      raceTest 10 $
+        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
+ 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

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 :: SpecWith Application
-spec struct c = around (withApp cfgDefault struct c) $ describe "CORS" $ do
+spec =
+  describe "CORS" $ do
     let preflightHeaders = [
           ("Accept", "*/*"),
           ("Origin", "http://example.com"),

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 :: SpecWith Application
-spec struct c = beforeAll resetDb
+spec =
-  . around (withApp cfgDefault struct c) $
   describe "Deleting" $ do
     context "existing record" $ do
       it "succeeds with 204 and deletion count" $

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 :: SpecWith Application
-spec struct c = beforeAll_ resetDb $ around (withApp cfgDefault struct c) $ do
+spec = do
   describe "Posting new record" $ do
     context "disparate json types" $ do
       it "accepts disparate json types" $ do

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 :: SpecWith Application
-spec struct c =
+spec =
-  beforeAll resetDb
-   . around (withApp (cfgLimitRows 3) struct c) $
   describe "Requesting many items with server limits enabled" $ do
     it "restricts results" $
       get "/items"

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 :: SpecWith Application
-spec struct c = around (withApp cfgDefault struct c) $ do
+spec = do
 
   describe "Querying a table with a column called count" $
     it "should not confuse count column with pg_catalog.count aggregate" $
@@ -371,7 +370,17 @@ spec struct c = around (withApp cfgDefault struct c) $ do
         [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |]
 
   describe "remote procedure call" $ do
-    context "a proc that returns a set" $
+    context "a proc that returns a set" $ do
+      it "returns paginated results" $
+        request methodPost "/rpc/getitemrange"
+                (rangeHdrs (ByteRangeFromTo 0 0))  [json| { "min": 2, "max": 4 } |]
+           `shouldRespondWith` ResponseMatcher {
+              matchBody    = Just [json| [{"id":3}] |]
+            , matchStatus = 206
+            , matchHeaders = ["Content-Range" <:> "0-0/2"]
+            }
+
+
       it "returns proper json" $
         post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith`
           [json| [ {"id": 3}, {"id":4} ] |]

test/Feature/RangeSpec.hs

@@ -5,16 +5,110 @@ 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 qualified Data.ByteString.Lazy         as BL
 
 import SpecHelper
-import PostgREST.Types (DbStructure(..))
+import Network.Wai (Application)
 
-spec :: DbStructure -> H.Connection -> Spec
+defaultRange :: BL.ByteString
-spec struct c = beforeAll resetDb
+defaultRange = [json| { "min": 0, "max": 15 } |]
-  . around (withApp cfgDefault struct c) $
+
+emptyRange :: BL.ByteString
+emptyRange = [json| { "min": 2, "max": 2 } |]
+
+spec :: SpecWith Application
+spec = do
+  describe "POST /rpc/getitemrange" $ do
+    context "without range headers" $ do
+      context "with response under server size limit" $
+        it "returns whole range with status 200" $
+           post "/rpc/getitemrange" defaultRange `shouldRespondWith` 200
+
+      context "when I don't want the count" $ do
+        it "returns range Content-Range with */* for empty range" $
+          request methodPost "/rpc/getitemrange"
+                  [("Prefer", "count=none")] emptyRange
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Just [json| [] |]
+            , matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "*/*"]
+            }
+
+        it "returns range Content-Range with range/*" $
+          request methodPost "/rpc/getitemrange"
+                  [("Prefer", "count=none")] defaultRange
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Just [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
+            , matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "0-14/*"]
+            }
+
+    context "with range headers" $ do
+
+      context "of acceptable range" $ do
+        it "succeeds with partial content" $ do
+          r <- request methodPost  "/rpc/getitemrange"
+                       (rangeHdrs $ ByteRangeFromTo 0 1) defaultRange
+          liftIO $ do
+            simpleHeaders r `shouldSatisfy`
+              matchHeader "Content-Range" "0-1/15"
+            simpleStatus r `shouldBe` partialContent206
+
+        it "understands open-ended ranges" $
+          request methodPost "/rpc/getitemrange"
+                  (rangeHdrs $ ByteRangeFrom 0) defaultRange
+            `shouldRespondWith` 200
+
+        it "returns an empty body when there are no results" $
+          request methodPost "/rpc/getitemrange"
+                  (rangeHdrs $ ByteRangeFromTo 0 1) emptyRange
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Just "[]"
+            , matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "*/0"]
+            }
+
+        it "allows one-item requests" $ do
+          r <- request methodPost  "/rpc/getitemrange"
+                       (rangeHdrs $ ByteRangeFromTo 0 0) defaultRange
+          liftIO $ do
+            simpleHeaders r `shouldSatisfy`
+              matchHeader "Content-Range" "0-0/15"
+            simpleStatus r `shouldBe` partialContent206
+
+        it "handles ranges beyond collection length via truncation" $ do
+          r <- request methodPost  "/rpc/getitemrange"
+                       (rangeHdrs $ ByteRangeFromTo 10 100) defaultRange
+          liftIO $ do
+            simpleHeaders r `shouldSatisfy`
+              matchHeader "Content-Range" "10-14/15"
+            simpleStatus r `shouldBe` partialContent206
+
+      context "of invalid range" $ do
+        it "fails with 416 for offside range" $
+          request methodPost  "/rpc/getitemrange"
+                  (rangeHdrs $ ByteRangeFromTo 1 0) emptyRange
+            `shouldRespondWith` 416
+
+        it "refuses a range with nonzero start when there are no items" $
+          request methodPost "/rpc/getitemrange"
+                  (rangeHdrs $ ByteRangeFromTo 1 2) emptyRange
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Nothing
+            , matchStatus  = 416
+            , matchHeaders = ["Content-Range" <:> "*/0"]
+            }
+
+        it "refuses a range requesting start past last item" $
+          request methodPost "/rpc/getitemrange"
+                  (rangeHdrs $ ByteRangeFromTo 100 199) defaultRange
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Nothing
+            , matchStatus  = 416
+            , matchHeaders = ["Content-Range" <:> "*/15"]
+            }
   describe "GET /items" $ do
-
     context "without range headers" $ do
       context "with response under server size limit" $
         it "returns whole range with status 200" $

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 "/" [] ""

test/Main.hs

@@ -3,13 +3,14 @@ module Main where
 import Test.Hspec
 import SpecHelper
 
-import qualified Hasql.Session as H
+import qualified Hasql.Pool as P
-import qualified Hasql.Connection as H
 
 import PostgREST.DbStructure (getDbStructure)
+import PostgREST.App (postgrest)
 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
@@ -22,22 +23,28 @@ main :: IO ()
 main = do
   setupDb
 
-  H.acquire (cs dbString) >>= \case
+  pool <- P.acquire (3, 10, cs testDbConn)
-    Left err -> error $ show err
+
-    Right c -> do
+  result <- P.use pool $ getDbStructure "test"
-      dbOrErr <- H.run (getDbStructure "test") c
+  let dbStructure = either (error.show) id result
-      -- Not using hspec-discover because we want to precompute
+      withApp = return $ postgrest testCfg dbStructure pool
-      -- the db structure and pass it to specs for speed
+      ltdApp  = return $ postgrest testLtdRowsCfg dbStructure pool
-      either (error.show) (hspec . specs c) dbOrErr
+
-      H.release c
+  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 conn dbStructure = do
+  specs = map (uncurry describe) [
-    describe "Feature.AuthSpec" $ Feature.AuthSpec.spec dbStructure conn
+      ("Feature.AuthSpec"         , Feature.AuthSpec.spec)
-    describe "Feature.CorsSpec" $ Feature.CorsSpec.spec dbStructure conn
+    , ("Feature.ConcurrentSpec"   , Feature.ConcurrentSpec.spec)
-    describe "Feature.DeleteSpec" $ Feature.DeleteSpec.spec dbStructure conn
+    , ("Feature.CorsSpec"         , Feature.CorsSpec.spec)
-    describe "Feature.InsertSpec" $ Feature.InsertSpec.spec dbStructure conn
+    , ("Feature.DeleteSpec"       , Feature.DeleteSpec.spec)
-    describe "Feature.QueryLimitedSpec" $ Feature.QueryLimitedSpec.spec dbStructure conn
+    , ("Feature.InsertSpec"       , Feature.InsertSpec.spec)
-    describe "Feature.QuerySpec" $ Feature.QuerySpec.spec dbStructure conn
+    , ("Feature.QuerySpec"        , Feature.QuerySpec.spec)
-    describe "Feature.RangeSpec" $ Feature.RangeSpec.spec dbStructure conn
+    , ("Feature.RangeSpec"        , Feature.RangeSpec.spec)
-    describe "Feature.StructureSpec" $ Feature.StructureSpec.spec dbStructure conn
+    , ("Feature.StructureSpec"    , Feature.StructureSpec.spec)
+    ]

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,42 +12,18 @@ 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
+testDbConn :: String
-dbString = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test"
+testDbConn = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test"
 
-cfg :: String -> Maybe Integer -> AppConfig
+testCfg :: AppConfig
-cfg conStr = AppConfig conStr "postgrest_test_anonymous" "test" 3000 (secret "safe") 10
+testCfg =
+  AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 Nothing True
 
-cfgDefault :: AppConfig
+testLtdRowsCfg :: AppConfig
-cfgDefault = cfg dbString Nothing
+testLtdRowsCfg =
-
+  AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 3) True
-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