jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Limit embeded items

Browse Source
This commit is contained in:
Ruslan Talpa
2016-05-26 09:56:28 +03:00
parent e76de196e0
commit 7c83edc402
11 changed files with 208 additions and 63 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/ApiRequest.hs
+17 -7
View File
@@ -21,7 +21,7 @@ import Network.HTTP.Types.Header (hAuthorization)
import Network.HTTP.Types.URI (parseSimpleQuery)
import Network.Wai (Request (..))
import Network.Wai.Parse (parseHttpAccept)
import PostgREST.RangeQuery (NonnegRange, rangeRequested)
import PostgREST.RangeQuery (NonnegRange, rangeRequested, limitToRange, toRange )
import PostgREST.Types (QualifiedIdentifier (..),
Schema, Payload(..),
UniformObjects(..))
@@ -60,7 +60,7 @@ data ApiRequest = ApiRequest {
-- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST
iAction :: Action
-- | Requested range of rows within response
, iRange :: NonnegRange
, iRange :: M.HashMap String NonnegRange
-- | The target, be it calling a proc or accessing a table
, iTarget :: Target
-- | The content type the client most desires (or JSON if undecided)
@@ -140,18 +140,20 @@ userApiRequest schema req reqBody =
ApiRequest {
iAction = action
, iRange = if singular then singletonRange 0 else rangeRequested hdrs
, iTarget = target
, iRange = setTopLevelRange headerRange $
setTopLevelRange urlRange $
M.fromList [(cs k, limitToRange $ cs $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["limit"] k ]
, iAccepts = pickContentType $ lookupHeader "accept"
, iPayload = relevantPayload
, iPreferRepresentation = representation
, iPreferSingular = singular
, iPreferCount = not $ singular || hasPrefer "count=none"
, iFilters = [ (cs k, fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn "order" k) ]
, iFilters = [ (cs k, fromJust v) | (k,v) <- qParams, isJust v, k /= "select", k /= "offset", not (endingIn ["order", "limit"] k) ]
, iSelect = if method == "DELETE"
then "*"
else fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
, iOrder = [(cs k, fromJust v) | (k,v) <- qParams, isJust v, endingIn "order" k ]
, iOrder = [(cs k, fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
, iCanonicalQS = urlEncodeVars
. sortBy (comparing fst)
. map (join (***) cs)
@@ -181,10 +183,18 @@ userApiRequest schema req reqBody =
tokenStr = case T.split (== ' ') (cs auth) of
("Bearer" : t : _) -> t
_ -> ""
endingIn:: T.Text -> T.Text -> Bool
endingIn word key = word == lastWord
endingIn:: [T.Text] -> T.Text -> Bool
endingIn xx key = lastWord `elem` xx
where lastWord = last $ T.split (=='.') key
headerRange = if singular then Just (singletonRange 0) else rangeRequested hdrs
urlRange = toRange (join $ lookup "limit" qParams) (join $ lookup "offset" qParams)
setTopLevelRange :: Maybe NonnegRange -> M.HashMap String NonnegRange -> M.HashMap String NonnegRange
setTopLevelRange Nothing ranges = ranges
setTopLevelRange (Just r) ranges = M.insert "limit" r ranges
-- PRIVATE ---------------------------------------------------------------
{-|
src/PostgREST/App.hs
+71 -34
View File
@@ -36,6 +36,8 @@ import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Data.Vector as V
import qualified Hasql.Transaction as H
import qualified Data.HashMap.Strict as M
import PostgREST.ApiRequest (ApiRequest(..), ContentType(..)
, Action(..), Target(..)
, PreferRepresentation (..)
@@ -101,7 +103,7 @@ app dbStructure conf apiRequest =
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (q, cq) -> do
let singular = iPreferSingular apiRequest
stm = createReadStatement q cq range singular
stm = createReadStatement q cq singular
shouldCount (contentType == TextCSV)
respondToRange $ do
row <- H.query () stm
@@ -187,7 +189,7 @@ app dbStructure conf apiRequest =
let p = V.head payload
jwtSecret = configJwtSecret conf
respondToRange $ do
row <- H.query () (callProc qi p range shouldCount)
row <- H.query () (callProc qi p topLevelRange shouldCount)
returnJWT <- H.query qi doesProcReturnJWT
let (tableTotal, queryTotal, body) = fromMaybe (Just 0, 0, emptyArray) row
(status, contentRange) = rangeHeader queryTotal tableTotal
@@ -219,18 +221,18 @@ app dbStructure conf apiRequest =
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
schema = cs $ configSchema conf
shouldCount = iPreferCount apiRequest
range = restrictRange (configMaxRows conf) $ iRange apiRequest
readDbRequest = DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest
topLevelRange = fromMaybe (rangeGeq 0) $ M.lookup "limit" $ iRange apiRequest
readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) apiRequest
mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest
selectQuery = requestToQuery schema <$> readDbRequest
countQuery = requestToCountQuery schema <$> readDbRequest
mutateQuery = requestToQuery schema <$> mutateDbRequest
readSqlParts = (,) <$> selectQuery <*> countQuery
mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
respondToRange response = if range == emptyRange
respondToRange response = if topLevelRange == emptyRange
then return $ errResponse status416 "HTTP Range error"
else response
rangeHeader queryTotal tableTotal = let frm = rangeOffset range
rangeHeader queryTotal tableTotal = let frm = rangeOffset topLevelRange
to = frm + toInteger queryTotal - 1
contentRange = contentRangeH frm to (toInteger <$> tableTotal)
status = rangeStatus frm to (toInteger <$> tableTotal)
@@ -287,53 +289,82 @@ augumentRequestWithJoin schema allRels request =
(first formatRelationError . addRelations schema allRels Nothing) request
>>= addJoinConditions schema
buildReadRequest :: [Relation] -> ApiRequest -> Either Text ReadRequest
buildReadRequest allRels apiRequest =
augumentRequestWithJoin schema rels =<<
first formatParserError (foldr addFilter <$> (foldr addOrder <$> readRequest <*> ords) <*> flts)
addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest)
addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
flip (foldr addFilter) <$> filters,
flip (foldr addOrder) <$> orders,
flip (foldr addRange) <$> ranges
]
{-
The esence of what is going on above is that we are composing tree functions
of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context
-}
where
filters :: Either ParseError [(Path, Filter)]
filters = mapM pRequestFilter flts
where
action = iAction apiRequest
flts = if action == ActionRead
then iFilters apiRequest
else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
orders :: Either ParseError [(Path, [OrderTerm])]
orders = mapM pRequestOrder $ iOrder apiRequest
ranges :: Either ParseError [(Path, NonnegRange)]
ranges = mapM pRequestRange $ M.toList $ iRange apiRequest
treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest
treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request
where
nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
buildReadRequest :: Maybe Integer -> [Relation] -> ApiRequest -> Either Text ReadRequest
buildReadRequest maxRows allRels apiRequest =
treeRestrictRange maxRows =<<
augumentRequestWithJoin schema relations =<<
first formatParserError readRequest
where
selStr = iSelect apiRequest
action = iAction apiRequest
target = iTarget apiRequest
(schema, rootTableName) = fromJust $ -- Make it safe
let target = iTarget apiRequest in
case target of
(TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)
_ -> Nothing
rootName = if action == ActionRead
then rootTableName
else sourceCTEName
filters = if action == ActionRead
then iFilters apiRequest
else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
rels = case action of
action :: Action
action = iAction apiRequest
readRequest :: Either ParseError ReadRequest
readRequest = addFiltersOrdersRanges apiRequest <*>
parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr
where
selStr = iSelect apiRequest
rootName = if action == ActionRead
then rootTableName
else sourceCTEName
relations :: [Relation]
relations = case action of
ActionCreate -> fakeSourceRelations ++ allRels
ActionUpdate -> fakeSourceRelations ++ allRels
_ -> allRels
where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
readRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr
flts = mapM pRequestFilter filters
orders = iOrder apiRequest
ords = mapM pRequestOrder orders
buildMutateRequest :: ApiRequest -> Either Text MutateRequest
buildMutateRequest apiRequest =
mutateApiRequest
buildMutateRequest apiRequest = case action of
ActionCreate -> Insert rootTableName <$> pure payload
ActionUpdate -> Update rootTableName <$> pure payload <*> filters
ActionDelete -> Delete rootTableName <$> filters
_ -> Left "Unsupported HTTP verb"
where
action = iAction apiRequest
target = iTarget apiRequest
payload = fromJust $ iPayload apiRequest
rootTableName = -- TODO: Make it safe
let target = iTarget apiRequest in
case target of
(TargetIdent (QualifiedIdentifier _ t) ) -> t
_ -> undefined
mutateApiRequest = case action of
ActionCreate -> Insert rootTableName <$> pure payload
ActionUpdate -> Update rootTableName <$> pure payload <*> cond
ActionDelete -> Delete rootTableName <$> cond
_ -> Left "Unsupported HTTP verb"
mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
where mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
addFilterToNode :: Filter -> ReadRequest -> ReadRequest
addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f
@@ -347,6 +378,12 @@ addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f
addOrder :: (Path, [OrderTerm]) -> ReadRequest -> ReadRequest
addOrder = addProperty addOrderToNode
addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest
addRangeToNode r (Node (q,i) f) = Node (q{range_=Just r}, i) f
addRange :: (Path, NonnegRange) -> ReadRequest -> ReadRequest
addRange = addProperty addRangeToNode
addProperty :: (a -> ReadRequest -> ReadRequest) -> (Path, a) -> ReadRequest -> ReadRequest
addProperty f ([], a) n = f a n
addProperty f (path, a) (Node rn forest) =
src/PostgREST/Parsers.hs
+9 -2
View File
@@ -11,6 +11,7 @@ import Data.Tree
import PostgREST.QueryBuilder (operators)
import PostgREST.Types
import Text.ParserCombinators.Parsec hiding (many, (<|>))
import PostgREST.RangeQuery (NonnegRange)
pRequestSelect :: Text -> Parser ReadRequest
@@ -18,7 +19,7 @@ pRequestSelect rootNodeName = do
fieldTree <- pFieldForest
return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree
where
readQuery = Select [] [rootNodeName] [] Nothing
readQuery = Select [] [rootNodeName] [] Nothing Nothing
treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) =
case fldForest of
@@ -26,7 +27,7 @@ pRequestSelect rootNodeName = do
_ -> Node (q, i) newForest
where
newForest =
foldr treeEntry (Node (Select [] [fn] [] Nothing, (fn, Nothing, alias)) []) fldForest:rForest
foldr treeEntry (Node (Select [] [fn] [] Nothing Nothing, (fn, Nothing, alias)) []) fldForest:rForest
pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
@@ -45,6 +46,12 @@ pRequestOrder (k, v) = (,) <$> path <*> ord
path = fst <$> treePath
ord = parse pOrder ("failed to parse order (" ++ v ++ ")") v
pRequestRange :: (String, NonnegRange) -> Either ParseError (Path, NonnegRange)
pRequestRange (k, v) = (,) <$> path <*> pure v
where
treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k
path = fst <$> treePath
ws :: Parser Text
ws = cs <$> many (oneOf " \t")
src/PostgREST/QueryBuilder.hs
+7 -6
View File
@@ -96,14 +96,14 @@ encodeUniformObjs :: HE.Params UniformObjects
encodeUniformObjs =
contramap (JSON.Array . V.map JSON.Object . unUniformObjects) (HE.value HE.json)
createReadStatement :: SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool ->
createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
H.Query () ResultsWithCount
createReadStatement selectQuery countQuery range isSingle countTotal asCsv =
createReadStatement selectQuery countQuery isSingle countTotal asCsv =
unicodeStatement sql HE.unit decodeStandard True
where
sql = [qc|
WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}
FROM ( SELECT * FROM {sourceCTEName} {limitF range}) t |]
FROM ( SELECT * FROM {sourceCTEName}) t |]
countResultF = if countTotal then "("<>countQuery<>")" else "null"
cols = intercalate ", " [
countResultF <> " AS total_result_set",
@@ -260,7 +260,7 @@ pgFmtLit x =
requestToCountQuery :: Schema -> DbRequest -> SqlQuery
requestToCountQuery _ (DbMutate _) = undefined
requestToCountQuery schema (DbRead (Node (Select _ _ conditions _, (mainTbl, _, _)) _)) =
requestToCountQuery schema (DbRead (Node (Select _ _ conditions _ _, (mainTbl, _, _)) _)) =
unwords [
"SELECT pg_catalog.count(1)",
"FROM ", fromQi $ QualifiedIdentifier schema mainTbl,
@@ -274,7 +274,7 @@ requestToCountQuery schema (DbRead (Node (Select _ _ conditions _, (mainTbl, _,
requestToQuery :: Schema -> DbRequest -> SqlQuery
requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined
requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined
requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (nodeName, maybeRelation, _)) forest)) =
requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) =
query
where
-- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
@@ -288,7 +288,8 @@ requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (nod
"FROM ", intercalate ", " (map (fromQi . toQi) tbls),
unwords joins,
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
orderF (fromMaybe [] ord)
orderF (fromMaybe [] ord),
fromMaybe "" $ limitF <$> range
]
orderF ts =
if null ts
src/PostgREST/RangeQuery.hs
+23 -5
View File
@@ -4,13 +4,16 @@ module PostgREST.RangeQuery (
, rangeLimit
, rangeOffset
, restrictRange
, rangeGeq
, NonnegRange
, limitToRange
, toRange
) where
import Control.Applicative
import Network.HTTP.Types.Header
import PostgREST.Types ()
import Data.Monoid ((<>))
import qualified Data.ByteString.Char8 as BS
import Data.Ranged.Boundaries
@@ -38,12 +41,13 @@ rangeParse range = do
rangeIntersection lower upper
Nothing -> rangeGeq 0
rangeRequested :: RequestHeaders -> NonnegRange
rangeRequested = rangeParse . fromMaybe "" . lookup hRange
rangeRequested :: RequestHeaders -> Maybe NonnegRange
rangeRequested headers = rangeParse <$> lookup hRange headers
restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange
restrictRange :: Maybe Integer -> Maybe NonnegRange -> Maybe NonnegRange
restrictRange Nothing r = r
restrictRange (Just limit) r =
restrictRange (Just limit) Nothing = Just $ rangeIntersection (rangeGeq 0) (rangeLeq (limit - 1))
restrictRange (Just limit) (Just r) = Just $
rangeIntersection r $
Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1)
@@ -66,3 +70,17 @@ rangeGeq n =
rangeLeq :: Integer -> NonnegRange
rangeLeq n =
Range BoundaryBelowAll (BoundaryAbove n)
limitToRange :: BS.ByteString -> NonnegRange
limitToRange l = rangeParse ("0-" <> cs (show (l' - 1)))
where l' = fromMaybe 0 (readMaybe $ cs l)::Integer
toRange :: Maybe String -> Maybe String -> Maybe NonnegRange
toRange Nothing Nothing = Nothing
toRange Nothing (Just o) = Just $ rangeParse $ cs $ show o' <> "-"
where o' = fromMaybe 0 (readMaybe $ cs o)::Integer
toRange (Just l) Nothing = Just $ limitToRange $ cs l
toRange (Just l) (Just o) = Just $ rangeParse $ cs $ show o' <> "-" <> show (o' + l' - 1)
where
l' = fromMaybe 0 (readMaybe $ cs l)::Integer
o' = fromMaybe 0 (readMaybe $ cs o)::Integer
src/PostgREST/Types.hs
+2 -1
View File
@@ -6,6 +6,7 @@ import Data.Int (Int32)
import Data.Text
import Data.Tree
import qualified Data.Vector as V
import PostgREST.RangeQuery (NonnegRange)
data DbStructure = DbStructure {
dbTables :: [Table]
@@ -111,7 +112,7 @@ type Cast = Text
type NodeName = Text
type SelectItem = (Field, Maybe Cast, Maybe Alias)
type Path = [Text]
data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm] } deriving (Show, Eq)
data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::Maybe NonnegRange } deriving (Show, Eq)
data MutateQuery = Insert { in_::TableName, qPayload::Payload }
| Delete { in_::TableName, where_::[Filter] }
| Update { in_::TableName, qPayload::Payload, where_::[Filter] } deriving (Show, Eq)