diff --git a/postgrest.cabal b/postgrest.cabal index 6cb819478..16ee5b41b 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -60,9 +60,9 @@ library PostgREST.RangeQuery PostgREST.Request.ApiRequest PostgREST.Request.DbRequestBuilder - PostgREST.Request.Parsers PostgREST.Request.Preferences PostgREST.Request.Types + PostgREST.Request.QueryParams PostgREST.Version PostgREST.Workers other-modules: Paths_postgrest diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index f7c13d3e8..7d36b31f1 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -79,6 +79,7 @@ import PostgREST.Request.Preferences (PreferCount (..), PreferParameters (..), PreferRepresentation (..), toAppliedHeader) +import PostgREST.Request.QueryParams (QueryParams (..)) import PostgREST.Request.Types (ReadRequest, fstFieldNames) import PostgREST.Version (prettyVersion) import PostgREST.Workers (connectionWorker, listener) @@ -278,7 +279,7 @@ handleRead headersOnly identifier context@RequestContext{..} = do , ( "Content-Location" , "/" <> toUtf8 (qiName identifier) - <> if BS.null iCanonicalQS then mempty else "?" <> iCanonicalQS + <> if BS.null (qsCanonical iQueryParams) then mempty else "?" <> qsCanonical iQueryParams ) ] ++ contentTypeHeaders context @@ -326,7 +327,7 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do ) , Just . RangeQuery.contentRangeH 1 0 $ if shouldCount iPreferCount then Just resQueryTotal else Nothing - , if null pkCols && isNothing iOnConflict then + , if null pkCols && isNothing (qsOnConflict iQueryParams) then Nothing else toAppliedHeader <$> iPreferResolution diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 9dd737d4b..a150e2be0 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -29,8 +29,10 @@ import Network.Wai (Response, responseLBS) import Network.HTTP.Types.Header (Header) -import PostgREST.ContentType (ContentType (..)) -import qualified PostgREST.ContentType as ContentType +import PostgREST.ContentType (ContentType (..)) +import qualified PostgREST.ContentType as ContentType +import PostgREST.Request.Types (ApiRequestError (..), + QPError (..)) import PostgREST.DbStructure.Proc (ProcDescription (..), ProcParam (..)) @@ -52,22 +54,6 @@ class (JSON.ToJSON a) => PgrstError a where errorResponseFor :: a -> Response errorResponseFor err = responseLBS (status err) (headers err) $ errorPayload err - - -data ApiRequestError - = ActionInappropriate - | InvalidRange - | InvalidBody ByteString - | ParseRequestError Text Text - | NoRelBetween Text Text Text - | AmbiguousRelBetween Text Text [Relationship] - | AmbiguousRpc [ProcDescription] - | NoRpc Text Text [Text] Bool ContentType Bool - | InvalidFilters - | UnacceptableSchema [Text] - | ContentTypeError [ByteString] - | UnsupportedVerb -- Unreachable? - instance PgrstError ApiRequestError where status InvalidRange = HTTP.status416 status InvalidFilters = HTTP.status405 @@ -75,6 +61,7 @@ instance PgrstError ApiRequestError where status UnsupportedVerb = HTTP.status405 status ActionInappropriate = HTTP.status405 status (ParseRequestError _ _) = HTTP.status400 + status (QueryParamError _) = HTTP.status400 status NoRelBetween{} = HTTP.status400 status AmbiguousRelBetween{} = HTTP.status300 status (AmbiguousRpc _) = HTTP.status300 @@ -87,6 +74,8 @@ instance PgrstError ApiRequestError where instance JSON.ToJSON ApiRequestError where toJSON (ParseRequestError message details) = JSON.object [ "message" .= message, "details" .= details] + toJSON (QueryParamError (QPError message details)) = JSON.object [ + "message" .= message, "details" .= details] toJSON ActionInappropriate = JSON.object [ "message" .= ("Bad Request" :: Text)] toJSON (InvalidBody errorMessage) = JSON.object [ diff --git a/src/PostgREST/Query/SqlFragment.hs b/src/PostgREST/Query/SqlFragment.hs index fb1941212..68e342d4e 100644 --- a/src/PostgREST/Query/SqlFragment.hs +++ b/src/PostgREST/Query/SqlFragment.hs @@ -15,11 +15,9 @@ module PostgREST.Query.SqlFragment , asJsonSingleF , countF , fromQi - , ftsOperators , limitOffsetF , locationF , normalizedBody - , operators , pgFmtColumn , pgFmtIdent , pgFmtJoinCondition @@ -38,7 +36,6 @@ module PostgREST.Query.SqlFragment import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Hasql.DynamicStatements.Snippet as SQL import qualified Hasql.Encoders as HE @@ -51,6 +48,7 @@ import PostgREST.DbStructure.Identifiers (FieldName, import PostgREST.RangeQuery (NonnegRange, allRange, rangeLimit, rangeOffset) import PostgREST.Request.Types (Alias, Field, Filter (..), + FtsOperator (..), JoinCondition (..), JsonOperand (..), JsonOperation (..), @@ -61,6 +59,7 @@ import PostgREST.Request.Types (Alias, Field, Filter (..), OrderDirection (..), OrderNulls (..), OrderTerm (..), SelectItem, + SimpleOperator (..), TrileanVal (..)) import Protolude hiding (cast) @@ -75,34 +74,31 @@ noLocationF = "array[]::text[]" sourceCTEName :: SqlFragment sourceCTEName = "pgrst_source" -operators :: M.HashMap Text SqlFragment -operators = M.union (M.fromList [ - ("eq", "="), - ("gte", ">="), - ("gt", ">"), - ("lte", "<="), - ("lt", "<"), - ("neq", "<>"), - ("like", "LIKE"), - ("ilike", "ILIKE"), - ("in", "IN"), - ("is", "IS"), - ("cs", "@>"), - ("cd", "<@"), - ("ov", "&&"), - ("sl", "<<"), - ("sr", ">>"), - ("nxr", "&<"), - ("nxl", "&>"), - ("adj", "-|-")]) ftsOperators +singleValOperator :: SimpleOperator -> SqlFragment +singleValOperator = \case + OpEqual -> "=" + OpGreaterThanEqual -> ">=" + OpGreaterThan -> ">" + OpLessThanEqual -> "<=" + OpLessThan -> "<" + OpNotEqual -> "<>" + OpLike -> "like" + OpILike -> "ilike" + OpContains -> "@>" + OpContained -> "<@" + OpOverlap -> "&&" + OpStrictlyLeft -> "<<" + OpStrictlyRight -> ">>" + OpNotExtendsRight -> "&<" + OpNotExtendsLeft -> "&>" + OpAdjacent -> "-|-" -ftsOperators :: M.HashMap Text SqlFragment -ftsOperators = M.fromList [ - ("fts", "@@ to_tsquery"), - ("plfts", "@@ plainto_tsquery"), - ("phfts", "@@ phraseto_tsquery"), - ("wfts", "@@ websearch_to_tsquery") - ] +ftsOperator :: FtsOperator -> SqlFragment +ftsOperator = \case + FilterFts -> "@@ to_tsquery" + FilterFtsPlain -> "@@ plainto_tsquery" + FilterFtsPhrase -> "@@ phraseto_tsquery" + FilterFtsWebsearch -> "@@ websearch_to_tsquery" -- | -- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads @@ -227,8 +223,8 @@ pgFmtOrderTerm qi ot = pgFmtFilter :: QualifiedIdentifier -> Filter -> SQL.Snippet pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of Op op val -> pgFmtFieldOp op <> " " <> case op of - "like" -> unknownLiteral (T.map star val) - "ilike" -> unknownLiteral (T.map star val) + OpLike -> unknownLiteral (T.map star val) + OpILike -> unknownLiteral (T.map star val) _ -> unknownLiteral val -- IS cannot be prepared. `PREPARE boolplan AS SELECT * FROM projects where id IS $1` will give a syntax error. @@ -249,11 +245,11 @@ pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper _ -> "= ANY (" <> unknownLiteral (pgBuildArrayLiteral vals) <> ") " Fts op lang val -> - pgFmtFieldOp op <> "(" <> ftsLang lang <> unknownLiteral val <> ") " + pgFmtFieldFts op <> "(" <> ftsLang lang <> unknownLiteral val <> ") " where ftsLang = maybe mempty (\l -> unknownLiteral l <> ", ") - pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op - sqlOperator o = SQL.sql $ M.lookupDefault "=" o operators + pgFmtFieldOp op = pgFmtField table fld <> " " <> SQL.sql (singleValOperator op) + pgFmtFieldFts op = pgFmtField table fld <> " " <> SQL.sql (ftsOperator op) notOp = if hasNot then "NOT" else mempty star c = if c == '*' then '%' else c diff --git a/src/PostgREST/Request/ApiRequest.hs b/src/PostgREST/Request/ApiRequest.hs index cd5271965..2dc9bfe8b 100644 --- a/src/PostgREST/Request/ApiRequest.hs +++ b/src/PostgREST/Request/ApiRequest.hs @@ -31,15 +31,11 @@ import qualified Data.Vector as V import Control.Arrow ((***)) import Data.Aeson.Types (emptyArray, emptyObject) -import Data.List (last, lookup, partition, union) +import Data.List (lookup, union) import Data.Maybe (fromJust) -import Data.Ranged.Boundaries (Boundary (..)) -import Data.Ranged.Ranges (Range (..), emptyRange, - rangeIntersection) -import Network.HTTP.Base (urlEncodeVars) +import Data.Ranged.Ranges (emptyRange, rangeIntersection) import Network.HTTP.Types.Header (hAuthorization, hCookie) -import Network.HTTP.Types.URI (parseQueryReplacePlus, - parseSimpleQuery) +import Network.HTTP.Types.URI (parseSimpleQuery) import Network.Wai (Request (..)) import Network.Wai.Parse (parseHttpAccept) import Web.Cookie (parseCookies) @@ -53,21 +49,19 @@ import PostgREST.DbStructure.Identifiers (FieldName, Schema) import PostgREST.DbStructure.Proc (ProcDescription (..), ProcParam (..), ProcsMap) -import PostgREST.Error (ApiRequestError (..)) -import PostgREST.Query.SqlFragment (ftsOperators, operators) import PostgREST.RangeQuery (NonnegRange, allRange, - rangeGeq, rangeLimit, - rangeOffset, rangeRequested, - restrictRange) -import PostgREST.Request.Parsers (pRequestColumns) + rangeRequested) import PostgREST.Request.Preferences (PreferCount (..), PreferParameters (..), PreferRepresentation (..), PreferResolution (..), PreferTransaction (..)) +import PostgREST.Request.QueryParams (QueryParams (..)) +import PostgREST.Request.Types (ApiRequestError (..)) import qualified PostgREST.ContentType as ContentType import qualified PostgREST.Request.Preferences as Preferences +import qualified PostgREST.Request.QueryParams as QueryParams import Protolude @@ -161,13 +155,8 @@ data ApiRequest = ApiRequest { , iPreferCount :: Maybe PreferCount -- ^ Whether the client wants a result count , iPreferResolution :: Maybe PreferResolution -- ^ Whether the client wants to UPSERT or ignore records on PK conflict , iPreferTransaction :: Maybe PreferTransaction -- ^ Whether the clients wants to commit or rollback the transaction - , iFilters :: [(Text, Text)] -- ^ Filters on the result ("id", "eq.10") - , iLogic :: [(Text, Text)] -- ^ &and and &or parameters used for complex boolean logic - , iSelect :: Maybe Text -- ^ &select parameter used to shape the response - , iOnConflict :: Maybe Text -- ^ &on_conflict parameter used to upsert on specific unique keys + , iQueryParams :: QueryParams.QueryParams , iColumns :: S.Set FieldName -- ^ parsed colums from &columns parameter and payload - , iOrder :: [(Text, Text)] -- ^ &order parameters for each level - , iCanonicalQS :: ByteString -- ^ Alphabetized (canonical) request query string for response URLs , iJWT :: Text -- ^ JSON Web Token , iHeaders :: [(ByteString, ByteString)] -- ^ HTTP request headers , iCookies :: [(ByteString, ByteString)] -- ^ Request Cookies @@ -180,12 +169,16 @@ data ApiRequest = ApiRequest { -- | Examines HTTP request and translates it into user intent. userApiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest -userApiRequest conf@AppConfig{..} dbStructure req reqBody +userApiRequest conf dbStructure req reqBody = + apiRequest conf dbStructure req reqBody =<< first QueryParamError (QueryParams.parse (rawQueryString req)) + +apiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> QueryParams.QueryParams -> Either ApiRequestError ApiRequest +apiRequest conf@AppConfig{..} dbStructure req reqBody queryparams@QueryParams{..} | isJust profile && fromJust profile `notElem` configDbSchemas = Left $ UnacceptableSchema $ toList configDbSchemas | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate | topLevelRange == emptyRange = Left InvalidRange | shouldParsePayload && isLeft payload = either (Left . InvalidBody) witness payload - | isLeft parsedColumns = either Left witness parsedColumns + | not expectParams && not (L.null qsParams) = Left $ ParseRequestError "Unexpected param or filter missing operator" ("Failed to parse " <> show qsParams) | otherwise = do acceptContentType <- findAcceptContentType conf action path accepts checkedTarget <- target @@ -200,16 +193,8 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody , iPreferCount = preferCount , iPreferResolution = preferResolution , iPreferTransaction = preferTransaction - , iFilters = filters - , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ] - , iSelect = toS <$> join (lookup "select" qParams) - , iOnConflict = toS <$> join (lookup "on_conflict" qParams) + , iQueryParams = queryparams , iColumns = payloadColumns - , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] - , iCanonicalQS = BS.pack $ urlEncodeVars - . L.sortOn fst - . map (join (***) BS.unpack . second (fromMaybe mempty)) - $ qString , iJWT = tokenStr , iHeaders = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie] , iCookies = maybe [] parseCookies $ lookupHeader "Cookie" @@ -221,24 +206,9 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody } where accepts = maybe [CTAny] (map ContentType.decodeContentType . parseHttpAccept) $ lookupHeader "accept" - -- queryString with '+' converted to ' '(space) - qString = parseQueryReplacePlus True $ rawQueryString req - -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..) - (filters, rpcQParams) = - case action of - ActionInvoke InvGet -> partitionFlts - ActionInvoke InvHead -> partitionFlts - _ -> (flts, []) - partitionFlts = partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts - flts = - [ (toS k, toS $ fromJust v) | - (k,v) <- qParams, isJust v, - k `notElem` ["select", "columns"], - not (endingIn ["order", "limit", "offset", "and", "or"] k) ] - hasOperator val = any (`T.isPrefixOf` val) $ - ((<> ".") <$> "not":M.keys operators) ++ - ((<> "(") <$> M.keys ftsOperators) - isEmbedPath = T.isInfixOf "." + + expectParams = isTargetingProc && method /= "POST" + isTargetingProc = case path of PathInfo{pHasRpc, pIsRootSpec} -> pHasRpc || pIsRootSpec _ -> False @@ -246,16 +216,19 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody PathInfo{pIsDefaultSpec=True} -> True _ -> False contentType = maybe CTApplicationJSON ContentType.decodeContentType $ lookupHeader "content-type" - columns - | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams) - | otherwise = Nothing - parsedColumns = pRequestColumns columns + + columns = + if action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] then + qsColumns + else + Nothing + payloadColumns = case (contentType, action) of - (_, ActionInvoke InvGet) -> S.fromList $ fst <$> rpcQParams - (_, ActionInvoke InvHead) -> S.fromList $ fst <$> rpcQParams + (_, ActionInvoke InvGet) -> S.fromList $ fst <$> qsParams + (_, ActionInvoke InvHead) -> S.fromList $ fst <$> qsParams (CTUrlEncoded, _) -> S.fromList $ map (T.decodeUtf8 . fst) $ parseSimpleQuery $ LBS.toStrict reqBody - _ -> case (relevantPayload, fromRight Nothing parsedColumns) of + _ -> case (relevantPayload, columns) of (Just ProcessedJSON{payKeys}, _) -> payKeys (Just RawJSON{}, Just cls) -> cls _ -> S.empty @@ -333,8 +306,8 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody relevantPayload = case (contentType, action) of -- Though ActionInvoke GET/HEAD doesn't really have a payload, we use the payload variable as a way -- to store the query string arguments to the function. - (_, ActionInvoke InvGet) -> targetToJsonRpcParams (rightToMaybe target) rpcQParams - (_, ActionInvoke InvHead) -> targetToJsonRpcParams (rightToMaybe target) rpcQParams + (_, ActionInvoke InvGet) -> targetToJsonRpcParams (rightToMaybe target) qsParams + (_, ActionInvoke InvHead) -> targetToJsonRpcParams (rightToMaybe target) qsParams (CTUrlEncoded, ActionInvoke InvPost) -> targetToJsonRpcParams (rightToMaybe target) $ (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody) _ | shouldParsePayload -> rightToMaybe payload | otherwise -> Nothing @@ -349,7 +322,6 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody _ -> PathUnknown method = requestMethod req hdrs = requestHeaders req - qParams = [(T.decodeUtf8 k, T.decodeUtf8 <$> v)|(k,v) <- qString] lookupHeader = flip lookup hdrs Preferences.Preferences{..} = Preferences.fromHeaders hdrs auth = fromMaybe "" $ lookupHeader hAuthorization @@ -357,24 +329,9 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody ("Bearer" : t : _) -> t ("bearer" : t : _) -> t _ -> "" - endingIn:: [Text] -> Text -> Bool - endingIn xx key = lastWord `elem` xx - where lastWord = last $ T.split (=='.') key - headerRange = rangeRequested hdrs - replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x] - limitParams :: M.HashMap Text NonnegRange - limitParams = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe . toS =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k] - offsetParams :: M.HashMap Text NonnegRange - offsetParams = M.fromList [(toS (replaceLast "limit" k), maybe allRange rangeGeq (readMaybe . toS =<< v)) | (k,v) <- qParams, isJust v, endingIn ["offset"] k] - urlRange = M.unionWith f limitParams offsetParams - where - f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1) - where - l = fromMaybe 0 $ rangeLimit rl - o = rangeOffset ro - ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange + ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" qsRanges))) qsRanges {-| Find the best match from a list of content types accepted by the diff --git a/src/PostgREST/Request/DbRequestBuilder.hs b/src/PostgREST/Request/DbRequestBuilder.hs index 0face2695..ed60dfe9e 100644 --- a/src/PostgREST/Request/DbRequestBuilder.hs +++ b/src/PostgREST/Request/DbRequestBuilder.hs @@ -24,10 +24,8 @@ module PostgREST.Request.DbRequestBuilder import qualified Data.HashMap.Strict as M import qualified Data.Set as S -import Control.Arrow ((***)) import Data.Either.Combinators (mapLeft) import Data.List (delete) -import Data.Text (isInfixOf) import Data.Tree (Tree (..)) import PostgREST.DbStructure.Identifiers (FieldName, @@ -41,20 +39,20 @@ import PostgREST.DbStructure.Relationship (Cardinality (..), Relationship (..)) import PostgREST.DbStructure.Table (Column (..), Table (..), tableQi) -import PostgREST.Error (ApiRequestError (..), - Error (..)) +import PostgREST.Error (Error (..)) import PostgREST.Query.SqlFragment (sourceCTEName) import PostgREST.RangeQuery (NonnegRange, allRange, restrictRange) import PostgREST.Request.ApiRequest (Action (..), ApiRequest (..), + InvokeMethod (..), Payload (..)) -import PostgREST.Request.Parsers import PostgREST.Request.Preferences import PostgREST.Request.Types import qualified PostgREST.DbStructure.Relationship as Relationship +import qualified PostgREST.Request.QueryParams as QueryParams import Protolude hiding (from) @@ -66,9 +64,9 @@ readRequest schema rootTableName maxRows allRels apiRequest = mapLeft ApiRequestError $ treeRestrictRange maxRows =<< augmentRequestWithJoin schema rootRels =<< - (addFiltersOrdersRanges apiRequest . initReadRequest rootName =<< pRequestSelect sel) + addFiltersOrdersRanges apiRequest (initReadRequest rootName sel) where - sel = fromMaybe "*" $ iSelect apiRequest -- default to all columns requested (SELECT *) for a non existent ?select querystring param + sel = QueryParams.qsSelect $ iQueryParams apiRequest (rootName, rootRels) = rootWithRels schema rootTableName allRels (iAction apiRequest) -- Get the root table name with its relationships according to the Action type. @@ -254,27 +252,22 @@ getJoinConditions previousAlias newAlias (Relationship Table{tableSchema=tSchema removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == decodeUtf8 sourceCTEName then mempty else schema) tbl addFiltersOrdersRanges :: ApiRequest -> ReadRequest -> Either ApiRequestError ReadRequest -addFiltersOrdersRanges apiRequest rReq = do - rFlts <- foldr addFilter rReq <$> filters - rOrds <- foldr addOrder rFlts <$> orders - rRngs <- foldr addRange rOrds <$> ranges - foldr addLogicTree rRngs <$> logicForest +addFiltersOrdersRanges ApiRequest{..} rReq = do + flip (foldr addLogicTree) qsLogic <$> (foldr addRange rOrds <$> ranges) where - filters :: Either ApiRequestError [(EmbedPath, Filter)] - filters = pRequestFilter `traverse` flts - orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])] - orders = pRequestOrder `traverse` iOrder apiRequest + rFlts = foldr addFilter rReq flts + rOrds = foldr addOrder rFlts qsOrder + QueryParams.QueryParams{..} = iQueryParams ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)] - ranges = pRequestRange `traverse` M.toList (iRange apiRequest) - logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)] - logicForest = pRequestLogicTree `traverse` logFrst - action = iAction apiRequest + ranges = first QueryParamError $ QueryParams.pRequestRange `traverse` M.toList iRange -- there can be no filters on the root table when we are doing insert/update/delete - (flts, logFrst) = - case action of - ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest) - ActionRead _ -> (iFilters apiRequest, iLogic apiRequest) - _ -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest) + flts = + case iAction of + ActionInvoke InvGet -> qsFilters + ActionInvoke InvHead -> qsFilters + ActionInvoke _ -> qsFilters + ActionRead _ -> qsFilters + _ -> qsFiltersNotRoot addFilterToNode :: Filter -> ReadRequest -> ReadRequest addFilterToNode flt (Node (q@Select {where_=lf}, i) f) = Node (q{where_=addFilterToLogicForest flt lf}::ReadQuery, i) f @@ -310,41 +303,36 @@ addProperty f (targetNodeName:remainingPath, a) (Node rn forest) = pathNode = find (\(Node (_,(nodeName,_,alias,_,_, _)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest mutateRequest :: Schema -> TableName -> ApiRequest -> [FieldName] -> ReadRequest -> Either Error MutateRequest -mutateRequest schema tName apiRequest pkCols readReq = mapLeft ApiRequestError $ - case action of - ActionCreate -> do - confCols <- case iOnConflict apiRequest of - Nothing -> pure pkCols - Just param -> pRequestOnConflict param - pure $ Insert qi (iColumns apiRequest) body ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings - ActionUpdate -> Update qi (iColumns apiRequest) body <$> combinedLogic <*> pure returnings +mutateRequest schema tName ApiRequest{..} pkCols readReq = mapLeft ApiRequestError $ + case iAction of + ActionCreate -> + Right $ Insert qi iColumns body ((,) <$> iPreferResolution <*> Just confCols) [] returnings + ActionUpdate -> Right $ Update qi iColumns body combinedLogic returnings ActionSingleUpsert -> - (\flts -> - if null (iLogic apiRequest) && - S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols && + if null qsLogic && + qsFilterFields == S.fromList pkCols && not (null (S.fromList pkCols)) && all (\case - Filter _ (OpExpr False (Op "eq" _)) -> True - _ -> False) flts - then Insert qi (iColumns apiRequest) body (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings + Filter _ (OpExpr False (Op OpEqual _)) -> True + _ -> False) filters + then Right $ Insert qi iColumns body (Just (MergeDuplicates, pkCols)) combinedLogic returnings else - Left InvalidFilters) =<< filters - ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings + Left InvalidFilters + ActionDelete -> Right $ Delete qi combinedLogic returnings _ -> Left UnsupportedVerb where + confCols = fromMaybe pkCols qsOnConflict + QueryParams.QueryParams{..} = iQueryParams qi = QualifiedIdentifier schema tName - action = iAction apiRequest returnings = - if iPreferRepresentation apiRequest == None + if iPreferRepresentation == None then [] else returningCols readReq pkCols - filters = map snd <$> pRequestFilter `traverse` mutateFilters - logic = map snd <$> pRequestLogicTree `traverse` logicFilters - combinedLogic = foldr addFilterToLogicForest <$> logic <*> filters -- update/delete filters can be only on the root table - (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest) - onlyRoot = filter (not . ( "." `isInfixOf` ) . fst) - body = payRaw <$> iPayload apiRequest -- the body is assumed to be json at this stage(ApiRequest validates) + filters = map snd qsFiltersRoot + logic = map snd qsLogic + combinedLogic = foldr addFilterToLogicForest logic filters + body = payRaw <$> iPayload -- the body is assumed to be json at this stage(ApiRequest validates) callRequest :: ProcDescription -> ApiRequest -> ReadRequest -> CallRequest callRequest proc apiReq readReq = FunctionCall { diff --git a/src/PostgREST/Request/Parsers.hs b/src/PostgREST/Request/Parsers.hs deleted file mode 100644 index fb2707fbc..000000000 --- a/src/PostgREST/Request/Parsers.hs +++ /dev/null @@ -1,300 +0,0 @@ -{-| -Module : PostgREST.Request.Parsers -Description : PostgREST parser combinators - -This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`. --} -module PostgREST.Request.Parsers - ( pColumns - , pLogicPath - , pLogicSingleVal - , pLogicTree - , pOrder - , pOrderTerm - , pRequestColumns - , pRequestFilter - , pRequestLogicTree - , pRequestOnConflict - , pRequestOrder - , pRequestRange - , pRequestSelect - , pSingleVal - , pTreePath - ) where - -import qualified Data.HashMap.Strict as M -import qualified Data.Set as S - -import Data.Either.Combinators (mapLeft) -import Data.Foldable (foldl1) -import Data.List (init, last) -import Data.Text (intercalate, replace, strip) -import Data.Tree (Tree (..)) -import Text.Parsec.Error (errorMessages, - showErrorMessages) -import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser, - anyChar, between, char, digit, - eof, errorPos, letter, - lookAhead, many1, noneOf, - notFollowedBy, oneOf, option, - optionMaybe, parse, sepBy1, - string, try, ()) - -import PostgREST.DbStructure.Identifiers (FieldName) -import PostgREST.Error (ApiRequestError (ParseRequestError)) -import PostgREST.Query.SqlFragment (ftsOperators, operators) -import PostgREST.RangeQuery (NonnegRange) - -import PostgREST.Request.Types - -import Protolude hiding (intercalate, option, replace, try) - -pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem] -pRequestSelect selStr = - mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) - -pRequestOnConflict :: Text -> Either ApiRequestError [FieldName] -pRequestOnConflict oncStr = - mapError $ parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr) - -pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter) -pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper) - where - treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k - oper = parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v - path = fst <$> treePath - fld = snd <$> treePath - -pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm]) -pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord' - where - treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k - path = fst <$> treePath - ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v - -pRequestRange :: (Text, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange) -pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v - where - treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k - path = fst <$> treePath - -pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree) -pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree - where - path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k - embedPath = fst <$> path - logicTree = do - op <- snd <$> path - -- Concat op and v to make pLogicTree argument regular, - -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)" - parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v) - -pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName)) -pRequestColumns colStr = - case colStr of - Just str -> - mapError $ Just . S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str) - _ -> Right Nothing - -ws :: Parser Text -ws = toS <$> many (oneOf " \t") - -lexeme :: Parser a -> Parser a -lexeme p = ws *> p <* ws - -pTreePath :: Parser (EmbedPath, Field) -pTreePath = do - p <- pFieldName `sepBy1` pDelimiter - jp <- option [] pJsonPath - return (init p, (last p, jp)) - -pFieldForest :: Parser [Tree SelectItem] -pFieldForest = pFieldTree `sepBy1` lexeme (char ',') - where - pFieldTree :: Parser (Tree SelectItem) - pFieldTree = try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|> - Node <$> pFieldSelect <*> pure [] - -pStar :: Parser Text -pStar = string "*" $> "*" - -pFieldName :: Parser Text -pFieldName = - pQuotedValue <|> - intercalate "-" . map toS <$> (many1 (letter <|> digit <|> oneOf "_ ") `sepBy1` dash) - "field name (* or [a..z0..9_])" - where - isDash :: GenParser Char st () - isDash = try ( char '-' >> notFollowedBy (char '>') ) - dash :: Parser Char - dash = isDash $> '-' - -pJsonPath :: Parser JsonPath -pJsonPath = many pJsonOperation - where - pJsonOperation :: Parser JsonOperation - pJsonOperation = pJsonArrow <*> pJsonOperand - - pJsonArrow = - try (string "->>" $> J2Arrow) <|> - try (string "->" $> JArrow) - - pJsonOperand = - let pJKey = JKey . toS <$> pFieldName - pJIdx = JIdx . toS <$> ((:) <$> option '+' (char '-') <*> many1 digit) <* pEnd - pEnd = try (void $ lookAhead (string "->")) <|> - try (void $ lookAhead (string "::")) <|> - try eof in - try pJIdx <|> try pJKey - -pField :: Parser Field -pField = lexeme $ (,) <$> pFieldName <*> option [] pJsonPath - -aliasSeparator :: Parser () -aliasSeparator = char ':' >> notFollowedBy (char ':') - -pRelationSelect :: Parser SelectItem -pRelationSelect = lexeme $ try ( do - alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) - fld <- pField - prm1 <- optionMaybe pEmbedParam - prm2 <- optionMaybe pEmbedParam - return (fld, Nothing, alias, embedParamHint prm1 <|> embedParamHint prm2, embedParamJoin prm1 <|> embedParamJoin prm2) - ) - where - pEmbedParam :: Parser EmbedParam - pEmbedParam = - char '!' *> ( - try (string "left" $> EPJoinType JTLeft) <|> - try (string "inner" $> EPJoinType JTInner) <|> - try (EPHint <$> pFieldName)) - embedParamHint prm = case prm of - Just (EPHint hint) -> Just hint - _ -> Nothing - embedParamJoin prm = case prm of - Just (EPJoinType jt) -> Just jt - _ -> Nothing - -pFieldSelect :: Parser SelectItem -pFieldSelect = lexeme $ - try ( - do - alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) - fld <- pField - cast' <- optionMaybe (string "::" *> many letter) - return (fld, toS <$> cast', alias, Nothing, Nothing) - ) - <|> do - s <- pStar - return ((s, []), Nothing, Nothing, Nothing, Nothing) - -pOpExpr :: Parser SingleVal -> Parser OpExpr -pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation - where - pOperation :: Parser Operation - pOperation = - Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal - <|> In <$> (try (string "in" *> pDelimiter) *> pListVal) - <|> Is <$> (try (string "is" *> pDelimiter) *> pTriVal) - <|> pFts - "operator (eq, gt, ...)" - - pTriVal = try (ciString "null" $> TriNull) - <|> try (ciString "unknown" $> TriUnknown) - <|> try (ciString "true" $> TriTrue) - <|> try (ciString "false" $> TriFalse) - "null or trilean value (unknown, true, false)" - - pFts = do - op <- foldl1 (<|>) (try . string . toS <$> ftsOps) - lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_"))) - pDelimiter >> Fts (toS op) (toS <$> lang) <$> pSVal - - ops = M.filterWithKey (const . flip notElem ("in":"is":ftsOps)) operators - ftsOps = M.keys ftsOperators - - -- case insensitive char and string - ciChar :: Char -> GenParser Char state Char - ciChar c = char c <|> char (toUpper c) - ciString :: [Char] -> GenParser Char state [Char] - ciString = traverse ciChar - -pSingleVal :: Parser SingleVal -pSingleVal = toS <$> many anyChar - -pListVal :: Parser ListVal -pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')') - -pListElement :: Parser Text -pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)")) - -pQuotedValue :: Parser Text -pQuotedValue = toS <$> (char '"' *> many pCharsOrSlashed <* char '"') - where - pCharsOrSlashed = noneOf "\\\"" <|> (char '\\' *> anyChar) - -pDelimiter :: Parser Char -pDelimiter = char '.' "delimiter (.)" - -pOrder :: Parser [OrderTerm] -pOrder = lexeme pOrderTerm `sepBy1` char ',' - -pOrderTerm :: Parser OrderTerm -pOrderTerm = do - fld <- pField - dir <- optionMaybe $ - try (pDelimiter *> string "asc" $> OrderAsc) <|> - try (pDelimiter *> string "desc" $> OrderDesc) - nls <- optionMaybe pNulls <* pEnd <|> - pEnd $> Nothing - return $ OrderTerm fld dir nls - where - pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|> - try (pDelimiter *> string "nullslast" $> OrderNullsLast) - pEnd = try (void $ lookAhead (char ',')) <|> - try eof - -pLogicTree :: Parser LogicTree -pLogicTree = Stmnt <$> try pLogicFilter - <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')')) - where - pLogicFilter :: Parser Filter - pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal - pNot :: Parser Bool - pNot = try (string "not" *> pDelimiter $> True) - <|> pure False - "negation operator (not)" - pLogicOp :: Parser LogicOperator - pLogicOp = try (string "and" $> And) - <|> string "or" $> Or - "logic operator (and, or)" - -pLogicSingleVal :: Parser SingleVal -pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)")) - where - pPgArray :: Parser Text - pPgArray = do - a <- string "{" - b <- many (noneOf "{}") - c <- string "}" - pure (toS $ a ++ b ++ c) - -pLogicPath :: Parser (EmbedPath, Text) -pLogicPath = do - path <- pFieldName `sepBy1` pDelimiter - let op = last path - notOp = "not." <> op - return (filter (/= "not") (init path), if "not" `elem` path then notOp else op) - -pColumns :: Parser [FieldName] -pColumns = pFieldName `sepBy1` lexeme (char ',') - -mapError :: Either ParseError a -> Either ApiRequestError a -mapError = mapLeft translateError - where - translateError e = - ParseRequestError message details - where - message = show $ errorPos e - details = strip $ replace "\n" " " $ toS - $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) diff --git a/src/PostgREST/Request/QueryParams.hs b/src/PostgREST/Request/QueryParams.hs new file mode 100644 index 000000000..aa969003d --- /dev/null +++ b/src/PostgREST/Request/QueryParams.hs @@ -0,0 +1,495 @@ +-- | +-- Module : PostgREST.Request.QueryParams +-- Description : Parser for PostgREST Query paramters +-- +-- This module is in charge of parsing all the querystring values in an url, e.g. +-- the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`. +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +module PostgREST.Request.QueryParams + ( parse + , QueryParams(..) + , pRequestRange + ) where + +import qualified Data.ByteString.Char8 as BS +import qualified Data.HashMap.Strict as M +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Base as HTTP +import qualified Network.HTTP.Types.URI as HTTP +import qualified Text.ParserCombinators.Parsec as P + +import Control.Arrow ((***)) +import Data.Either.Combinators (mapLeft) +import Data.List (init, last) +import Data.Ranged.Boundaries (Boundary (..)) +import Data.Ranged.Ranges (Range (..)) +import Data.Tree (Tree (..)) +import Text.Parsec.Error (errorMessages, + showErrorMessages) +import Text.Parsec.Prim (parserFail) +import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser, + anyChar, between, char, digit, + eof, errorPos, letter, + lookAhead, many1, noneOf, + notFollowedBy, oneOf, + optionMaybe, sepBy1, string, + try, ()) + +import PostgREST.DbStructure.Identifiers (FieldName) +import PostgREST.RangeQuery (NonnegRange, allRange, + rangeGeq, rangeLimit, + rangeOffset, restrictRange) + +import PostgREST.Request.Types (EmbedParam (..), EmbedPath, Field, + Filter (..), FtsOperator (..), + JoinType (..), JsonOperand (..), + JsonOperation (..), JsonPath, ListVal, + LogicOperator (..), LogicTree (..), + OpExpr (..), Operation (..), + OrderDirection (..), OrderNulls (..), + OrderTerm (..), QPError (..), + SelectItem, SingleVal, + SimpleOperator (..), + TrileanVal (..)) + +import Protolude hiding (try) + + +-- $setup +-- Setup for doctests +-- >>> import Text.Pretty.Simple (pPrint) +-- >>> deriving instance Show QPError +-- >>> deriving instance Show TrileanVal +-- >>> deriving instance Show FtsOperator +-- >>> deriving instance Show SimpleOperator +-- >>> deriving instance Show Operation +-- >>> deriving instance Show OpExpr +-- >>> deriving instance Show JsonOperand +-- >>> deriving instance Show JsonOperation +-- >>> deriving instance Show Filter +-- >>> deriving instance Show JoinType + +data QueryParams = + QueryParams + { qsCanonical :: ByteString + -- ^ Canonical representation of the query params, sorted alphabetically + , qsParams :: [(Text, Text)] + -- ^ Parameters for RPC calls + , qsRanges :: M.HashMap Text (Range Integer) + -- ^ Ranges derived from &limit and &offset params + , qsOrder :: [(EmbedPath, [OrderTerm])] + -- ^ &order parameters for each level + , qsLogic :: [(EmbedPath, LogicTree)] + -- ^ &and and &or parameters used for complex boolean logic + , qsColumns :: Maybe (S.Set FieldName) + -- ^ &columns parameter and payload + , qsSelect :: [Tree SelectItem] + -- ^ &select parameter used to shape the response + , qsFilters :: [(EmbedPath, Filter)] + -- ^ Filters on the result from e.g. &id=e.10 + , qsFiltersRoot :: [(EmbedPath, Filter)] + -- ^ Subset of the filters that apply on the root table + , qsFiltersNotRoot :: [(EmbedPath, Filter)] + -- ^ Subset of the filters that do not apply on the root table + , qsFilterFields :: S.Set FieldName + -- ^ Set of fields that filters apply to + , qsOnConflict :: Maybe [FieldName] + -- ^ &on_conflict parameter used to upsert on specific unique keys + } + +-- | +-- Parse query parameters from a query string like "id=eq.1&select=name". +-- +-- The canonical representation of the query string has paramters sorted alphabetically: +-- +-- >>> qsCanonical <$> parse "a=1&c=3&b=2&d" +-- Right "a=1&b=2&c=3&d=" +-- +-- 'select' is a reserved parameter that selects the fields to be returned: +-- +-- >>> qsSelect <$> parse "select=name,location" +-- Right [Node {rootLabel = (("name",[]),Nothing,Nothing,Nothing,Nothing), subForest = []},Node {rootLabel = (("location",[]),Nothing,Nothing,Nothing,Nothing), subForest = []}] +-- +-- Filters are parameters whose value contains an operator, separated by a '.' from its value: +-- +-- >>> qsFilters <$> parse "a.b=eq.0" +-- Right [(["a"],Filter {field = ("b",[]), opExpr = OpExpr False (Op OpEqual "0")})] +-- +-- If the operator specified in a filter does not exist, parsing the query string fails: +-- +-- >>> qsFilters <$> parse "a.b=noop.0" +-- Left (QPError "\"failed to parse filter (noop.0)\" (line 1, column 6)" "unknown single value operator noop") +parse :: ByteString -> Either QPError QueryParams +parse qs = + QueryParams + canonical + params + ranges + <$> pRequestOrder `traverse` order + <*> pRequestLogicTree `traverse` logic + <*> pRequestColumns columns + <*> pRequestSelect select + <*> pRequestFilter `traverse` filters + <*> pRequestFilter `traverse` filtersRoot + <*> pRequestFilter `traverse` filtersNotRoot + <*> pure (S.fromList (fst <$> filters)) + <*> sequenceA (pRequestOnConflict <$> onConflict) + where + logic = filter (endingIn ["and", "or"] . fst) nonemptyParams + select = fromMaybe "*" $ lookupParam "select" + onConflict = lookupParam "on_conflict" + columns = lookupParam "columns" + order = filter (endingIn ["order"] . fst) nonemptyParams + limits = filter (endingIn ["limit"] . fst) nonemptyParams + -- Replace .offset ending with .limit to be able to match those params later in a map + offsets = first (replaceLast "limit") <$> filter (endingIn ["offset"] . fst) nonemptyParams + lookupParam :: Text -> Maybe Text + lookupParam needle = toS <$> join (L.lookup needle qParams) + nonemptyParams = mapMaybe (\(k, v) -> (k,) <$> v) qParams + + qString = HTTP.parseQueryReplacePlus True qs + + qParams = [(T.decodeUtf8 k, T.decodeUtf8 <$> v)|(k,v) <- qString] + + canonical = + BS.pack $ HTTP.urlEncodeVars + . L.sortOn fst + . map (join (***) BS.unpack . second (fromMaybe mempty)) + $ qString + + endingIn:: [Text] -> Text -> Bool + endingIn xx key = lastWord `elem` xx + where lastWord = L.last $ T.split (== '.') key + + (filters, params) = L.partition isParam filtersAndParams + isParam (k, v) = isEmbedPath k || hasOperator v || hasFtsOperator v + + filtersAndParams = filter (isFilterOrParam . fst) nonemptyParams + isFilterOrParam k = not (endingIn reservedEmbeddable k) && notElem k reserved + reserved = ["select", "columns", "on_conflict"] + reservedEmbeddable = ["order", "limit", "offset", "and", "or"] + + (filtersNotRoot, filtersRoot) = L.partition isNotRoot filters + isNotRoot = flip T.isInfixOf "." . fst + + -- TODO: These checks are redundant to the parsers, should use parsers to differentiate params + hasOperator val = + case T.splitOn "." val of + "not" : _ : _ -> True + "is" : _ -> True + "in" : _ -> True + x : _ -> isJust (operator x) || isJust (ftsOperator x) + _ -> False + + hasFtsOperator val = + case T.splitOn "(" val of + x : _ : _ -> isJust $ ftsOperator x + _ -> False + + isEmbedPath = T.isInfixOf "." + replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) <> [x] + + ranges :: M.HashMap Text (Range Integer) + ranges = M.unionWith f limitParams offsetParams + where + f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1) + where + l = fromMaybe 0 $ rangeLimit rl + o = rangeOffset ro + + limitParams = + M.fromList [(k, restrictRange (readMaybe $ toS v) allRange) | (k,v) <- limits] + + offsetParams = + M.fromList [(k, maybe allRange rangeGeq (readMaybe $ toS v)) | (k,v) <- offsets] + +operator :: Text -> Maybe SimpleOperator +operator = \case + "eq" -> Just OpEqual + "gte" -> Just OpGreaterThanEqual + "gt" -> Just OpGreaterThan + "lte" -> Just OpLessThanEqual + "lt" -> Just OpLessThan + "neq" -> Just OpNotEqual + "like" -> Just OpLike + "ilike" -> Just OpILike + "cs" -> Just OpContains + "cd" -> Just OpContained + "ov" -> Just OpOverlap + "sl" -> Just OpStrictlyLeft + "sr" -> Just OpStrictlyRight + "nxr" -> Just OpNotExtendsRight + "nxl" -> Just OpNotExtendsLeft + "adj" -> Just OpAdjacent + _ -> Nothing + +ftsOperator :: Text -> Maybe FtsOperator +ftsOperator = \case + "fts" -> Just FilterFts + "plfts" -> Just FilterFtsPlain + "phfts" -> Just FilterFtsPhrase + "wfts" -> Just FilterFtsWebsearch + _ -> Nothing + + +-- PARSERS + + +pRequestSelect :: Text -> Either QPError [Tree SelectItem] +pRequestSelect selStr = + mapError $ P.parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) + +pRequestOnConflict :: Text -> Either QPError [FieldName] +pRequestOnConflict oncStr = + mapError $ P.parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr) + +pRequestFilter :: (Text, Text) -> Either QPError (EmbedPath, Filter) +pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper) + where + treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k + oper = P.parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v + path = fst <$> treePath + fld = snd <$> treePath + +pRequestOrder :: (Text, Text) -> Either QPError (EmbedPath, [OrderTerm]) +pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord' + where + treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k + path = fst <$> treePath + ord' = P.parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v + +pRequestRange :: (Text, NonnegRange) -> Either QPError (EmbedPath, NonnegRange) +pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v + where + treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k + path = fst <$> treePath + +pRequestLogicTree :: (Text, Text) -> Either QPError (EmbedPath, LogicTree) +pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree + where + path = P.parse pLogicPath ("failed to parse logic path (" ++ toS k ++ ")") $ toS k + embedPath = fst <$> path + logicTree = do + op <- snd <$> path + -- Concat op and v to make pLogicTree argument regular, + -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)" + P.parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v) + +pRequestColumns :: Maybe Text -> Either QPError (Maybe (S.Set FieldName)) +pRequestColumns colStr = + case colStr of + Just str -> + mapError $ Just . S.fromList <$> P.parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str) + _ -> Right Nothing + +ws :: Parser Text +ws = toS <$> many (oneOf " \t") + +lexeme :: Parser a -> Parser a +lexeme p = ws *> p <* ws + +pTreePath :: Parser (EmbedPath, Field) +pTreePath = do + p <- pFieldName `sepBy1` pDelimiter + jp <- P.option [] pJsonPath + return (init p, (last p, jp)) + +pFieldForest :: Parser [Tree SelectItem] +pFieldForest = pFieldTree `sepBy1` lexeme (char ',') + where + pFieldTree :: Parser (Tree SelectItem) + pFieldTree = try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|> + Node <$> pFieldSelect <*> pure [] + +pStar :: Parser Text +pStar = string "*" $> "*" + +pFieldName :: Parser Text +pFieldName = + pQuotedValue <|> + T.intercalate "-" . map toS <$> (many1 (letter <|> digit <|> oneOf "_ ") `sepBy1` dash) + "field name (* or [a..z0..9_])" + where + isDash :: GenParser Char st () + isDash = try ( char '-' >> notFollowedBy (char '>') ) + dash :: Parser Char + dash = isDash $> '-' + +pJsonPath :: Parser JsonPath +pJsonPath = many pJsonOperation + where + pJsonOperation :: Parser JsonOperation + pJsonOperation = pJsonArrow <*> pJsonOperand + + pJsonArrow = + try (string "->>" $> J2Arrow) <|> + try (string "->" $> JArrow) + + pJsonOperand = + let pJKey = JKey . toS <$> pFieldName + pJIdx = JIdx . toS <$> ((:) <$> P.option '+' (char '-') <*> many1 digit) <* pEnd + pEnd = try (void $ lookAhead (string "->")) <|> + try (void $ lookAhead (string "::")) <|> + try eof in + try pJIdx <|> try pJKey + +pField :: Parser Field +pField = lexeme $ (,) <$> pFieldName <*> P.option [] pJsonPath + +aliasSeparator :: Parser () +aliasSeparator = char ':' >> notFollowedBy (char ':') + +pRelationSelect :: Parser SelectItem +pRelationSelect = lexeme $ try ( do + alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) + fld <- pField + prm1 <- optionMaybe pEmbedParam + prm2 <- optionMaybe pEmbedParam + return (fld, Nothing, alias, embedParamHint prm1 <|> embedParamHint prm2, embedParamJoin prm1 <|> embedParamJoin prm2) + ) + where + pEmbedParam :: Parser EmbedParam + pEmbedParam = + char '!' *> ( + try (string "left" $> EPJoinType JTLeft) <|> + try (string "inner" $> EPJoinType JTInner) <|> + try (EPHint <$> pFieldName)) + embedParamHint prm = case prm of + Just (EPHint hint) -> Just hint + _ -> Nothing + embedParamJoin prm = case prm of + Just (EPJoinType jt) -> Just jt + _ -> Nothing + +pFieldSelect :: Parser SelectItem +pFieldSelect = lexeme $ + try ( + do + alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) + fld <- pField + cast' <- optionMaybe (string "::" *> many letter) + return (fld, toS <$> cast', alias, Nothing, Nothing) + ) + <|> do + s <- pStar + return ((s, []), Nothing, Nothing, Nothing, Nothing) + +pOpExpr :: Parser SingleVal -> Parser OpExpr +pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation + where + pOperation :: Parser Operation + pOperation = pIn <|> pIs <|> try pFts <|> pOp "operator (eq, gt, ...)" + + pIn = In <$> (try (string "in" *> pDelimiter) *> pListVal) + pIs = Is <$> (try (string "is" *> pDelimiter) *> pTriVal) + + pOp = do + opStr <- try (P.manyTill anyChar (try pDelimiter)) + op <- parseMaybe ("unknown single value operator " <> opStr) . operator $ toS opStr + Op op <$> pSVal + + pTriVal = try (ciString "null" $> TriNull) + <|> try (ciString "unknown" $> TriUnknown) + <|> try (ciString "true" $> TriTrue) + <|> try (ciString "false" $> TriFalse) + "null or trilean value (unknown, true, false)" + + pFts = do + opStr <- try (P.many (noneOf ".(")) + op <- parseMaybe ("unknown fts operator " <> opStr) . ftsOperator $ toS opStr + lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_"))) + pDelimiter >> Fts op (toS <$> lang) <$> pSVal + + parseMaybe :: [Char] -> Maybe a -> Parser a + parseMaybe err Nothing = parserFail err + parseMaybe _ (Just x) = pure x + + -- case insensitive char and string + ciChar :: Char -> GenParser Char state Char + ciChar c = char c <|> char (toUpper c) + ciString :: [Char] -> GenParser Char state [Char] + ciString = traverse ciChar + +pSingleVal :: Parser SingleVal +pSingleVal = toS <$> many anyChar + +pListVal :: Parser ListVal +pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')') + +pListElement :: Parser Text +pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)")) + +pQuotedValue :: Parser Text +pQuotedValue = toS <$> (char '"' *> many pCharsOrSlashed <* char '"') + where + pCharsOrSlashed = noneOf "\\\"" <|> (char '\\' *> anyChar) + +pDelimiter :: Parser Char +pDelimiter = char '.' "delimiter (.)" + +pOrder :: Parser [OrderTerm] +pOrder = lexeme pOrderTerm `sepBy1` char ',' + +pOrderTerm :: Parser OrderTerm +pOrderTerm = do + fld <- pField + dir <- optionMaybe $ + try (pDelimiter *> string "asc" $> OrderAsc) <|> + try (pDelimiter *> string "desc" $> OrderDesc) + nls <- optionMaybe pNulls <* pEnd <|> + pEnd $> Nothing + return $ OrderTerm fld dir nls + where + pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|> + try (pDelimiter *> string "nullslast" $> OrderNullsLast) + pEnd = try (void $ lookAhead (char ',')) <|> + try eof + +pLogicTree :: Parser LogicTree +pLogicTree = Stmnt <$> try pLogicFilter + <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')')) + where + pLogicFilter :: Parser Filter + pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal + pNot :: Parser Bool + pNot = try (string "not" *> pDelimiter $> True) + <|> pure False + "negation operator (not)" + pLogicOp :: Parser LogicOperator + pLogicOp = try (string "and" $> And) + <|> string "or" $> Or + "logic operator (and, or)" + +pLogicSingleVal :: Parser SingleVal +pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)")) + where + pPgArray :: Parser Text + pPgArray = do + a <- string "{" + b <- many (noneOf "{}") + c <- string "}" + pure (toS $ a ++ b ++ c) + +pLogicPath :: Parser (EmbedPath, Text) +pLogicPath = do + path <- pFieldName `sepBy1` pDelimiter + let op = last path + notOp = "not." <> op + return (filter (/= "not") (init path), if "not" `elem` path then notOp else op) + +pColumns :: Parser [FieldName] +pColumns = pFieldName `sepBy1` lexeme (char ',') + +mapError :: Either ParseError a -> Either QPError a +mapError = mapLeft translateError + where + translateError e = + QPError message details + where + message = show $ errorPos e + details = T.strip $ T.replace "\n" " " $ toS + $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) diff --git a/src/PostgREST/Request/Types.hs b/src/PostgREST/Request/Types.hs index f33ba9a14..f52467f3c 100644 --- a/src/PostgREST/Request/Types.hs +++ b/src/PostgREST/Request/Types.hs @@ -3,6 +3,7 @@ module PostgREST.Request.Types ( Alias , Depth , EmbedParam(..) + , ApiRequestError(..) , EmbedPath , Field , Filter(..) @@ -26,6 +27,7 @@ module PostgREST.Request.Types , OrderDirection(..) , OrderNulls(..) , OrderTerm(..) + , QPError(..) , ReadNode , ReadQuery(..) , ReadRequest @@ -33,6 +35,8 @@ module PostgREST.Request.Types , SingleVal , TrileanVal(..) , fstFieldNames + , SimpleOperator(..) + , FtsOperator(..) ) where import qualified Data.ByteString.Lazy as LBS @@ -40,9 +44,11 @@ import qualified Data.Set as S import Data.Tree (Tree (..)) +import PostgREST.ContentType (ContentType (..)) import PostgREST.DbStructure.Identifiers (FieldName, QualifiedIdentifier) -import PostgREST.DbStructure.Proc (ProcParam (..)) +import PostgREST.DbStructure.Proc (ProcDescription (..), + ProcParam (..)) import PostgREST.DbStructure.Relationship (Relationship) import PostgREST.RangeQuery (NonnegRange) import PostgREST.Request.Preferences (PreferResolution) @@ -50,6 +56,24 @@ import PostgREST.Request.Preferences (PreferResolution) import Protolude + +data ApiRequestError + = ActionInappropriate + | InvalidRange + | InvalidBody ByteString + | ParseRequestError Text Text + | QueryParamError QPError + | NoRelBetween Text Text Text + | AmbiguousRelBetween Text Text [Relationship] + | AmbiguousRpc [ProcDescription] + | NoRpc Text Text [Text] Bool ContentType Bool + | InvalidFilters + | UnacceptableSchema [Text] + | ContentTypeError [ByteString] + | UnsupportedVerb -- Unreachable? + +data QPError = QPError Text Text + type ReadRequest = Tree ReadNode type MutateRequest = MutateQuery type CallRequest = CallQuery @@ -208,13 +232,12 @@ data OpExpr = deriving (Eq) data Operation - = Op Operator SingleVal + = Op SimpleOperator SingleVal | In ListVal | Is TrileanVal - | Fts Operator (Maybe Language) SingleVal + | Fts FtsOperator (Maybe Language) SingleVal deriving (Eq) -type Operator = Text type Language = Text -- | Represents a single value in a filter, e.g. id=eq.singleval @@ -230,3 +253,30 @@ data TrileanVal | TriNull | TriUnknown deriving Eq + +data SimpleOperator + = OpEqual + | OpGreaterThanEqual + | OpGreaterThan + | OpLessThanEqual + | OpLessThan + | OpNotEqual + | OpLike + | OpILike + | OpContains + | OpContained + | OpOverlap + | OpStrictlyLeft + | OpStrictlyRight + | OpNotExtendsRight + | OpNotExtendsLeft + | OpAdjacent + deriving Eq + +-- | Operators for full text search operators +data FtsOperator + = FilterFts + | FilterFtsPlain + | FilterFtsPhrase + | FilterFtsWebsearch + deriving Eq diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 10250204c..5a38fb143 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -914,7 +914,7 @@ spec actualPgVersion = do { matchHeaders = [matchContentTypeJson] } it "fails if an operator is not given" $ - get "/ghostBusters?id=0" `shouldRespondWith` [json| {"details":"unexpected \"0\" expecting \"not\" or operator (eq, gt, ...)","message":"\"failed to parse filter (0)\" (line 1, column 1)"} |] + get "/ghostBusters?id=0" `shouldRespondWith` [json| {"details":"Failed to parse [(\"id\",\"0\")]","message":"Unexpected param or filter missing operator"} |] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } diff --git a/test/doctests/Main.hs b/test/doctests/Main.hs index 86e8fd168..064efbf2a 100644 --- a/test/doctests/Main.hs +++ b/test/doctests/Main.hs @@ -8,10 +8,10 @@ import Protolude main :: IO () main = doctest - [ "--verbose" - , "-XOverloadedStrings" + [ "-XOverloadedStrings" , "-XNoImplicitPrelude" , "-XStandaloneDeriving" , "-isrc" , "src/PostgREST/Request/Preferences.hs" + , "src/PostgREST/Request/QueryParams.hs" ]