diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs --- a/src/PostgREST/App.hs +++ b/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.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 diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -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 diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -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 diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -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 diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -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 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -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" diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -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 diff --git a/test/Feature/ConcurrentSpec.hs b/test/Feature/ConcurrentSpec.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -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"), diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -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" $ diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -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 diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/QueryLimitedSpec.hs @@ -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 diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -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} ] |] diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -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" $ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -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 "/" [] "" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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) + ] diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- 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,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