From cbbb1871bba3b63719d1b96b7691505aa8578ece Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 5 Dec 2015 18:51:51 -0800 Subject: [PATCH 1/4] Add --max-rows option (no automated tests yet) Fixes #288 --- postgrest.cabal | 3 +++ src/PostgREST/ApiRequest.hs | 6 +++--- src/PostgREST/App.hs | 6 +++--- src/PostgREST/Config.hs | 3 +++ src/PostgREST/QueryBuilder.hs | 25 ++++++++++++++++--------- src/PostgREST/RangeQuery.hs | 25 ++++++++++++++++--------- test/SpecHelper.hs | 2 +- 7 files changed, 45 insertions(+), 25 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 8d6d62056..6ad23dfa6 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -45,6 +45,7 @@ executable postgrest , parsec , postgrest , regex-tdfa + , safe >= 0.3 && < 0.4 , scientific , string-conversions , text @@ -98,6 +99,7 @@ library , optparse-applicative , parsec , regex-tdfa + , safe , scientific , string-conversions , text @@ -181,6 +183,7 @@ Test-Suite spec , parsec , process , regex-tdfa + , safe , scientific , string-conversions , text diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 10eb324c2..622fe37b9 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -20,7 +20,7 @@ import PostgREST.RangeQuery (NonnegRange, rangeRequested) import PostgREST.Types (QualifiedIdentifier (..), Schema, Payload(..), UniformObjects(..)) -import Data.Ranged.Ranges (singletonRange) +import Data.Ranged.Ranges (singletonRange) type RequestBody = BL.ByteString @@ -51,7 +51,7 @@ data ApiRequest = ApiRequest { -- | Set to Nothing for unknown HTTP verbs iAction :: Action -- | Set to Nothing for malformed range - , iRange :: Maybe NonnegRange + , iRange :: NonnegRange -- | Set to Nothing for strangely nested urls , iTarget :: Target -- | The content type the client most desires (or JSON if undecided) @@ -115,7 +115,7 @@ userApiRequest schema req reqBody = ApiRequest { iAction = action - , iRange = if singular then Just (singletonRange 0) else rangeRequested hdrs + , iRange = if singular then singletonRange 0 else rangeRequested hdrs , iTarget = target , iAccepts = pickContentType $ lookupHeader "accept" , iPayload = relevantPayload diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index ca5b66539..93d0db7db 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -73,11 +73,11 @@ app dbStructure conf reqBody req = case selectQuery of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right q -> do - let range = iRange apiRequest + let range = restrictRange (configMaxRows conf) $ iRange apiRequest singular = iPreferSingular apiRequest stm = createReadStatement q range singular (iPreferCount apiRequest) (contentType == TextCSV) - if range == Just emptyRange + if range == emptyRange then return $ errResponse status416 "HTTP Range error" else do row <- H.maybeEx stm @@ -87,7 +87,7 @@ app dbStructure conf reqBody req = then responseLBS status404 [] "" else responseLBS status200 [contentTypeH] (fromMaybe "{}" body) else do - let frm = fromMaybe 0 $ rangeOffset <$> range + let frm = rangeOffset range to = frm+queryTotal-1 contentRange = contentRangeH frm to tableTotal status = rangeStatus frm to tableTotal diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index e7a9cc110..13e631636 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -30,6 +30,7 @@ import Network.Wai import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) import Options.Applicative import Paths_postgrest (version) +import Safe (readMay) import Web.JWT (Secret, secret) import Prelude @@ -41,6 +42,7 @@ data AppConfig = AppConfig { , configSchema :: String , configJwtSecret :: Secret , configPool :: Int + , configMaxRows :: Maybe Int } argParser :: Parser AppConfig @@ -53,6 +55,7 @@ argParser = AppConfig <*> (secret . cs <$> 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)) defaultCorsPolicy :: CorsResourcePolicy defaultCorsPolicy = CorsResourcePolicy Nothing diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index b819c2562..418bca3ad 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -34,7 +34,6 @@ import qualified Data.Aeson as JSON import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset) import Control.Error (note, fromMaybe, mapMaybe) -import Control.Monad (join) import qualified Data.HashMap.Strict as HM import Data.List (find) import Data.Monoid ((<>)) @@ -61,10 +60,10 @@ instance Monoid PStmt where mempty = B.Stmt "" empty True type StatementT = PStmt -> PStmt -createReadStatement :: SqlQuery -> Maybe NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres +createReadStatement :: SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres createReadStatement selectQuery range isSingle countTable asCsv = B.Stmt ( - wrapQuery selectQuery [ + wrapLimitedQuery selectQuery [ if countTable then countAllF else countNoneF, countF, "null", -- location header can not be calucalted @@ -91,7 +90,7 @@ createWriteStatement selectQuery mutateQuery isSingle echoRequested else if isSingle then asJsonSingleF else asJsonF else "null" - ] selectQuery Nothing + ] selectQuery ) (V.singleton . B.encodeValue . JSON.Array . V.map JSON.Object $ rows) True addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest @@ -426,19 +425,27 @@ withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")" fromF :: SqlFragment -> SqlFragment -> SqlFragment fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t" -limitF :: Maybe NonnegRange -> SqlFragment +limitF :: NonnegRange -> SqlFragment limitF r = "LIMIT " <> limit <> " OFFSET " <> offset where - limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r - offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r + limit = maybe "ALL" (cs . show) $ rangeLimit r + offset = cs . show $ rangeOffset r selectStarF :: SqlFragment selectStarF = "SELECT * FROM " <> sourceSubqueryName -wrapQuery :: SqlQuery -> [Text] -> Text -> Maybe NonnegRange -> SqlQuery -wrapQuery source selectColumns returnSelect range = +wrapLimitedQuery :: SqlQuery -> [Text] -> Text -> NonnegRange -> SqlQuery +wrapLimitedQuery source selectColumns returnSelect range = withSourceF source <> " SELECT " <> intercalate ", " selectColumns <> " " <> fromF returnSelect ( limitF range ) + +wrapQuery :: SqlQuery -> [Text] -> Text -> SqlQuery +wrapQuery source selectColumns returnSelect = + withSourceF source <> + " SELECT " <> + intercalate ", " selectColumns <> + " " <> + fromF returnSelect "" diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index ff9997378..c82a88b3d 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -3,6 +3,7 @@ module PostgREST.RangeQuery ( , rangeRequested , rangeLimit , rangeOffset +, restrictRange , NonnegRange ) where @@ -25,20 +26,26 @@ import Prelude type NonnegRange = Range Int -rangeParse :: BS.ByteString -> Maybe NonnegRange +rangeParse :: BS.ByteString -> NonnegRange rangeParse range = do let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString - parsedRange <- listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) + case listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) of + Just parsedRange -> + let [_, from, to] = readMaybe . cs <$> parsedRange + lower = fromMaybe emptyRange (rangeGeq <$> from) + upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to) in + rangeIntersection lower upper + Nothing -> rangeGeq 0 - let [_, from, to] = readMaybe . cs <$> parsedRange - let lower = fromMaybe emptyRange (rangeGeq <$> from) - let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to) +rangeRequested :: RequestHeaders -> NonnegRange +rangeRequested = rangeParse . fromMaybe "" . lookup hRange - return $ rangeIntersection lower upper - -rangeRequested :: RequestHeaders -> Maybe NonnegRange -rangeRequested = (rangeParse =<<) . lookup hRange +restrictRange :: Maybe Int -> NonnegRange -> NonnegRange +restrictRange Nothing r = r +restrictRange (Just limit) r = + rangeIntersection r $ + Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1) rangeLimit :: NonnegRange -> Maybe Int rangeLimit range = diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 867abca38..2cae197d5 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -42,7 +42,7 @@ isLeft (Left _ ) = True isLeft _ = False cfg :: AppConfig -cfg = AppConfig dbString 3000 "postgrest_anonymous" "test" (secret "safe") 10 +cfg = AppConfig dbString 3000 "postgrest_anonymous" "test" (secret "safe") 10 Nothing testPoolOpts :: PoolSettings testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30 From f4c73c7666f5cb3abb24bd251ff79df1bfcf51ff Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 5 Dec 2015 19:31:53 -0800 Subject: [PATCH 2/4] Test for --max-rows behavior --- test/Feature/AuthSpec.hs | 2 +- test/Feature/CorsSpec.hs | 2 +- test/Feature/DeleteSpec.hs | 2 +- test/Feature/InsertSpec.hs | 2 +- test/Feature/QueryLimitedSpec.hs | 32 ++++++++++++++++++++++++++++++++ test/Feature/QuerySpec.hs | 2 +- test/Feature/RangeSpec.hs | 2 +- test/Feature/StructureSpec.hs | 2 +- test/SpecHelper.hs | 17 +++++++++++------ 9 files changed, 50 insertions(+), 13 deletions(-) create mode 100644 test/Feature/QueryLimitedSpec.hs diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index 136ae4549..0454d65c5 100644 --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -12,7 +12,7 @@ import SpecHelper spec :: Spec spec = beforeAll (clearTable "postgrest.auth") . afterAll_ (clearTable "postgrest.auth") - $ around withApp + $ around (withApp cfgDefault) $ describe "authorization" $ do it "hides tables that anonymous does not own" $ diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs index 35ff69982..1e0da8695 100644 --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -12,7 +12,7 @@ import Network.HTTP.Types -- }}} spec :: Spec -spec = around withApp $ describe "CORS" $ do +spec = around (withApp cfgDefault) $ describe "CORS" $ do let preflightHeaders = [ ("Accept", "*/*"), ("Origin", "http://example.com"), diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs index adf946e50..7e368925d 100644 --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -8,7 +8,7 @@ import Network.HTTP.Types spec :: Spec spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items") - . around withApp $ + . around (withApp cfgDefault) $ describe "Deleting" $ do context "existing record" $ do it "succeeds with 204 and deletion count" $ diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 3639c72d1..83d79870a 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -17,7 +17,7 @@ import Control.Monad (replicateM_) import TestTypes(IncPK(..), CompoundPK(..)) spec :: Spec -spec = afterAll_ resetDb $ around withApp $ do +spec = afterAll_ resetDb $ around (withApp cfgDefault) $ do describe "Posting new record" $ do after_ (clearTable "menagerie") . context "disparate csv types" $ do it "accepts disparate json types" $ do diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs new file mode 100644 index 000000000..31ec64d49 --- /dev/null +++ b/test/Feature/QueryLimitedSpec.hs @@ -0,0 +1,32 @@ +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 + +spec :: Spec +spec = + beforeAll (clearTable "items" >> createItems 15) + . afterAll_ (clearTable "items") + . around (withApp $ cfgLimitRows 3) $ do + + 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 index 99ec84403..9f9441c8e 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -22,7 +22,7 @@ spec = createLikableStrings >> createJsonData) . afterAll_ (clearTable "items" >> clearTable "complex_items" >> clearTable "no_pk" >> clearTable "simple_pk") - . around withApp $ do + . around (withApp cfgDefault) $ do describe "Querying a table with a column called count" $ it "should not confuse count column with pg_catalog.count aggregate" $ diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs index 35c22a27b..30cd57fd5 100644 --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -10,7 +10,7 @@ import SpecHelper spec :: Spec spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items") - . around withApp $ + . around (withApp cfgDefault) $ describe "GET /items" $ do context "without range headers" $ do diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 339a36044..d32048577 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -9,7 +9,7 @@ import SpecHelper import Network.HTTP.Types spec :: Spec -spec = around withApp $ do +spec = around (withApp cfgDefault) $ do describe "GET /" $ do it "lists views in schema" $ request methodGet "/" [] "" diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 2cae197d5..ccb1eefa3 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -41,8 +41,13 @@ isLeft :: Either a b -> Bool isLeft (Left _ ) = True isLeft _ = False -cfg :: AppConfig -cfg = AppConfig dbString 3000 "postgrest_anonymous" "test" (secret "safe") 10 Nothing +cfgDefault :: AppConfig +cfgDefault = AppConfig dbString 3000 "postgrest_anonymous" "test" (secret "safe") 10 Nothing + +cfgLimitRows :: Int -> AppConfig +cfgLimitRows limit = + AppConfig dbString 3000 "postgrest_anonymous" "test" + (secret "safe") 10 (Just limit) testPoolOpts :: PoolSettings testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30 @@ -50,20 +55,20 @@ testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30 pgSettings :: P.Settings pgSettings = P.StringSettings $ cs dbString -withApp :: ActionWith Application -> IO () -withApp perform = do +withApp :: AppConfig -> ActionWith Application -> IO () +withApp config perform = do pool :: H.Pool P.Postgres <- H.acquirePool pgSettings testPoolOpts let txSettings = Just (H.ReadCommitted, Just True) - dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema cfg) + dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema config) db <- either (fail . show) return dbOrError perform $ middle $ \req resp -> do time <- getPOSIXTime body <- strictRequestBody req result <- liftIO $ H.session pool $ H.tx txSettings - $ runWithClaims cfg time (app db cfg body) req + $ runWithClaims config time (app db config body) req either (resp . pgErrResponse) resp result where middle = defaultMiddle From 598b2bfbda4092f5820eca6cbe5e2bff6bf9e748 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 5 Dec 2015 19:41:21 -0800 Subject: [PATCH 3/4] Remove lint --- test/Feature/QueryLimitedSpec.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs index 31ec64d49..e4e84d84d 100644 --- a/test/Feature/QueryLimitedSpec.hs +++ b/test/Feature/QueryLimitedSpec.hs @@ -12,8 +12,7 @@ spec :: Spec spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items") - . around (withApp $ cfgLimitRows 3) $ do - + . around (withApp $ cfgLimitRows 3) $ describe "Requesting many items with server limits enabled" $ do it "restricts results" $ get "/items" From e88fa7db31e761ae469d132d99a50a8503e578cc Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 5 Dec 2015 19:59:30 -0800 Subject: [PATCH 4/4] Docs and changelog --- CHANGELOG.md | 1 + docs/install/server.md | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7d851ccb0..0aa4b5d6d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,6 +11,7 @@ This project adheres to [Semantic Versioning](http://semver.org/). ### Added - Allow order by computed columns - @diogob +- Set max rows in response with --max-rows - @begriffs ## [0.3.0.1] - 2015-11-27 diff --git a/docs/install/server.md b/docs/install/server.md index a7822d895..4977c6f89 100644 --- a/docs/install/server.md +++ b/docs/install/server.md @@ -92,6 +92,10 @@ The possible flags are:
Max connections to use in db pool. Defaults to to 10, but you should find an optimal value for your db by running the SQL command show max_connections;
+ +
-m, --max-rows
+
Max number of rows to return in a read request. The default is + no limit.