postgrest 0.3.0.4 → 0.3.1.0

raw patch · 18 files changed

+379/−208 lines, 18 filesdep +asyncdep +hasql-pooldep +hasql-transactiondep −resource-pooldep ~aesondep ~hasqldep ~unixPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async, hasql-pool, hasql-transaction, monad-control, mtl, transformers, transformers-base

Dependencies removed: resource-pool

Dependency ranges changed: aeson, hasql, unix, warp

API changes (from Hackage documentation)

Files

• postgrest.cabal +23/−6
• src/PostgREST/App.hs +53/−28
• src/PostgREST/Config.hs +2/−0
• src/PostgREST/Error.hs +21/−10
• src/PostgREST/Main.hs +17/−44
• src/PostgREST/Middleware.hs +3/−3
• src/PostgREST/QueryBuilder.hs +15/−27
• test/Feature/AuthSpec.hs +3/−5
• test/Feature/ConcurrentSpec.hs +51/−0
• test/Feature/CorsSpec.hs +4/−4
• test/Feature/DeleteSpec.hs +3/−7
• test/Feature/InsertSpec.hs +3/−4
• test/Feature/QueryLimitedSpec.hs +29/−0
• test/Feature/QuerySpec.hs +14/−5
• test/Feature/RangeSpec.hs +100/−6
• test/Feature/StructureSpec.hs +4/−4
• test/Main.hs +26/−19
• test/SpecHelper.hs +8/−36

@@ -2,7 +2,7 @@ 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 @@  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 @@                      , 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 @@                      , contravariant                      , errors                      , hasql+                     , hasql-transaction+                     , hasql-pool                      , http-types                      , interpolatedstring-perl6                      , jwt+                     , mtl                      , optparse-applicative                      , parsec                      , regex-tdfa@@ -123,14 +128,17 @@ 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 @@                      , SpecHelper                      , TestTypes   Build-Depends:       aeson+                     , async                      , base                      , base64-string                      , bytestring@@ -157,6 +166,8 @@                      , contravariant                      , errors                      , hasql+                     , hasql-pool+                     , hasql-transaction                      , heredoc                      , hspec == 2.2.*                      , hspec-wai@@ -164,6 +175,8 @@                      , http-types                      , interpolatedstring-perl6                      , jwt+                     , monad-control+                     , mtl                      , optparse-applicative                      , parsec                      , process@@ -173,11 +186,15 @@                      , string-conversions                      , text                      , time+                     , transformers+                     , transformers-base                      , unordered-containers+                     , unix                      , vector                      , wai                      , wai-cors                      , wai-extra                      , wai-middleware-static+                     , warp                      , HTTP                      , Ranged-sets

@@ -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.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.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 @@                                         , 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 @@       case readSqlParts of         Left e -> return $ responseLBS status400 [jsonH] $ cs e         Right (q, cq) -> do-          let range = restrictRange (configMaxRows conf) $ iRange apiRequest-              singular = iPreferSingular apiRequest+          let singular = iPreferSingular apiRequest               stm = createReadStatement q cq range singular-                    (iPreferCount apiRequest) (contentType == TextCSV)-          if range == emptyRange-          then return $ errResponse status416 "HTTP Range error"-          else do+                    shouldCount (contentType == TextCSV)+          respondToRange $ do             row <- H.query () stm             let (tableTotal, queryTotal, _ , body) = row             if singular@@ -85,10 +101,7 @@               then responseLBS status404 [] ""               else responseLBS status200 [contentTypeH] (cs body)             else do-              let frm = rangeOffset range-                  to = frm + toInteger queryTotal - 1-                  contentRange = contentRangeH frm to (toInteger <$> tableTotal)-                  status = rangeStatus frm to (toInteger <$> tableTotal)+              let (status, contentRange) = rangeHeader queryTotal tableTotal                   canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?                     . sortBy (comparing fst)                     . map (join (***) cs)@@ -165,14 +178,16 @@         then do           let p = V.head payload               jwtSecret = configJwtSecret conf--          bodyJson <- H.query () (callProc qi p)-          returnJWT <- H.query qi doesProcReturnJWT-          return $ responseLBS status200 [jsonH]-                 (let body = fromMaybe emptyArray bodyJson in-                    if returnJWT-                    then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"-                    else cs $ encode body)+          respondToRange $ do+            row <- H.query () (callProc qi p range shouldCount)+            returnJWT <- H.query qi doesProcReturnJWT+            let (tableTotal, queryTotal, body) = fromMaybe (Just 0, 0, emptyArray) row+                (status, contentRange) = rangeHeader queryTotal tableTotal+              in+              return $ responseLBS status [jsonH, contentRange]+                      (if returnJWT+                      then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"+                      else cs $ encode body)         else return notFound      (ActionRead, TargetRoot, Nothing) -> do@@ -196,6 +211,8 @@   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 @@   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

@@ -43,6 +43,7 @@   , configJwtSecret :: Secret   , configPool      :: Int   , configMaxRows   :: Maybe Integer+  , configQuiet     :: Bool   }  argParser :: Parser AppConfig@@ -55,6 +56,7 @@       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

@@ -7,11 +7,13 @@  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 @@ 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 @@     "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 @@     '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

@@ -9,29 +9,20 @@                                                        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           Network.Wai+import qualified Hasql.Pool                           as P 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 @@    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-    time <- getPOSIXTime-    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)-      Right c -> do-        resOrError <- handleReq c-        either (respond . pgErrResponse) respond resOrError+  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

@@ -7,7 +7,7 @@ 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 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

@@ -18,7 +18,6 @@   , callProc   , createReadStatement   , createWriteStatement-  , inTransaction   , operators   , pgFmtIdent   , pgFmtLit@@ -27,11 +26,9 @@   , 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 @@     updatedForest = mapM (addJoinConditions schema) forest     addCond query' con = query'{flt_=con ++ flt_ query'} -callProc :: QualifiedIdentifier -> JSON.Object -> H.Query () (Maybe JSON.Value)-callProc qi params =-  H.statement sql HE.unit decodeObj True+type ProcResults = (Maybe Int64, Int64, JSON.Value)+callProc :: QualifiedIdentifier -> JSON.Object -> NonnegRange -> Bool -> H.Query () (Maybe ProcResults)+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-    decodeObj = HD.maybeRow (HD.value HD.json)+    _callSql = [qc| from {fromQi qi}({_args}) |] :: BS.ByteString+    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 @@  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"

@@ -5,15 +5,13 @@ 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

@@ -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

@@ -5,16 +5,16 @@ 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"),

@@ -4,15 +4,11 @@ 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" $

@@ -6,7 +6,6 @@ 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 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

@@ -0,0 +1,29 @@+module Feature.QueryLimitedSpec where++import Test.Hspec hiding (pendingWith)+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON+import Network.HTTP.Types+import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus))++import SpecHelper+import Network.Wai (Application)++spec :: SpecWith Application+spec =+  describe "Requesting many items with server limits enabled" $ do+    it "restricts results" $+      get "/items"+        `shouldRespondWith` ResponseMatcher {+          matchBody    = Just [json| [{"id":1},{"id":2},{"id":3}] |]+        , matchStatus  = 206+        , matchHeaders = ["Content-Range" <:> "0-2/15"]+        }++    it "respects additional client limiting" $ do+      r <- request methodGet  "/items"+                   (rangeHdrs $ ByteRangeFromTo 0 1) ""+      liftIO $ do+        simpleHeaders r `shouldSatisfy`+          matchHeader "Content-Range" "0-1/15"+        simpleStatus r `shouldBe` partialContent206

@@ -5,14 +5,13 @@ 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" $@@ -371,7 +370,17 @@         [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} ] |]

@@ -5,16 +5,110 @@ 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-spec struct c = beforeAll resetDb-  . around (withApp cfgDefault struct c) $-  describe "GET /items" $ do+defaultRange :: BL.ByteString+defaultRange = [json| { "min": 0, "max": 15 } |] +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" $

@@ -3,15 +3,15 @@ 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 :: DbStructure -> H.Connection -> Spec-spec struct c = around (withApp cfgDefault struct c) $ do+spec :: SpecWith Application+spec = do+   describe "GET /" $ do     it "lists views in schema" $       request methodGet "/" [] ""

@@ -3,13 +3,14 @@ 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.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 = 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 (3, 10, cs testDbConn) +  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 $ 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-    describe "Feature.AuthSpec" $ Feature.AuthSpec.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.QuerySpec"        , Feature.QuerySpec.spec)+    , ("Feature.RangeSpec"        , Feature.RangeSpec.spec)+    , ("Feature.StructureSpec"    , Feature.StructureSpec.spec)+    ]

@@ -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 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"--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+testDbConn :: String+testDbConn = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test" -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)+testCfg :: AppConfig+testCfg =+  AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 Nothing True -    handleReq c >>= \case-      Left err -> do-        void $ H.run (H.sql "rollback;") c-        resp $ pgErrResponse err-      Right res -> resp res+testLtdRowsCfg :: AppConfig+testLtdRowsCfg =+  AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 3) True  setupDb :: IO () setupDb = do