diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 0a136c83b..f7582225a 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -3,6 +3,7 @@ Module : PostgREST.Request.ApiRequest Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. -} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -32,12 +33,13 @@ import qualified Data.Set as S import qualified Data.Text.Encoding as T import qualified Data.Vector as V +import Data.Either.Combinators (mapBoth) + import Control.Arrow ((***)) import Data.Aeson.Types (emptyArray, emptyObject) import Data.List (lookup, union) import Data.Ranged.Ranges (emptyRange, rangeIntersection, rangeIsEmpty) -import Data.Tree (Tree (..)) import Network.HTTP.Types.Header (RequestHeaders, hCookie) import Network.HTTP.Types.URI (parseSimpleQuery) import Network.Wai (Request (..)) @@ -51,8 +53,7 @@ import PostgREST.ApiRequest.Preferences (PreferCount (..), PreferTransaction (..)) import PostgREST.ApiRequest.QueryParams (QueryParams (..)) import PostgREST.ApiRequest.Types (ApiRequestError (..), - RangeError (..), - SelectItem (..)) + RangeError (..)) import PostgREST.Config (AppConfig (..), OpenAPIMode (..)) import PostgREST.MediaType (MTPlanAttrs (..), @@ -62,13 +63,9 @@ import PostgREST.RangeQuery (NonnegRange, allRange, convertToLimitZeroRange, hasLimitZero, rangeRequested) -import PostgREST.SchemaCache (SchemaCache (..)) import PostgREST.SchemaCache.Identifiers (FieldName, QualifiedIdentifier (..), Schema) -import PostgREST.SchemaCache.Proc (ProcDescription (..), - ProcParam (..), ProcsMap, - procReturnsScalar) import qualified PostgREST.ApiRequest.Preferences as Preferences import qualified PostgREST.ApiRequest.QueryParams as QueryParams @@ -90,6 +87,7 @@ data Payload -- ^ Keys of the object or if it's an array these keys are guaranteed to -- be the same across all its objects } + | ProcessedUrlEncoded { payArray :: [(Text, Text)], payKeys :: S.Set Text } | RawJSON { payRaw :: LBS.ByteString } | RawPay { payRaw :: LBS.ByteString } @@ -114,41 +112,9 @@ data PathInfo } -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier - | TargetProc{tProc :: ProcDescription, tpIsRootSpec :: Bool} + | TargetProc{tProc :: QualifiedIdentifier, tpIsRootSpec :: Bool} | TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/" --- | RPC query param value `/rpc/func?v=`, used for VARIADIC functions on form-urlencoded POST and GETs --- | It can be fixed `?v=1` or repeated `?v=1&v=2&v=3. -data RpcParamValue = Fixed Text | Variadic [Text] -instance JSON.ToJSON RpcParamValue where - toJSON (Fixed v) = JSON.toJSON v - toJSON (Variadic v) = JSON.toJSON v - -toRpcParamValue :: ProcDescription -> (Text, Text) -> (Text, RpcParamValue) -toRpcParamValue proc (k, v) | prmIsVariadic k = (k, Variadic [v]) - | otherwise = (k, Fixed v) - where - prmIsVariadic prm = isJust $ find (\ProcParam{ppName, ppVar} -> ppName == prm && ppVar) $ pdParams proc - --- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"} -jsonRpcParams :: ProcDescription -> [(Text, Text)] -> Payload -jsonRpcParams proc prms = - if not $ pdHasVariadic proc then -- if proc has no variadic param, save steps and directly convert to json - ProcessedJSON (JSON.encode $ HM.fromList $ second JSON.toJSON <$> prms) (S.fromList $ fst <$> prms) - else - let paramsMap = HM.fromListWith mergeParams $ toRpcParamValue proc <$> prms in - ProcessedJSON (JSON.encode paramsMap) (S.fromList $ HM.keys paramsMap) - where - mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue - mergeParams (Variadic a) (Variadic b) = Variadic $ b ++ a - mergeParams v _ = v -- repeated params for non-variadic parameters are not merged - -targetToJsonRpcParams :: Maybe Target -> [(Text, Text)] -> Maybe Payload -targetToJsonRpcParams target params = - case target of - Just TargetProc{tProc} -> Just $ jsonRpcParams tProc params - _ -> Nothing - {-| Describes what the user wants to do. This data type is a translation of the raw elements of an HTTP request into domain @@ -176,22 +142,50 @@ data ApiRequest = ApiRequest { , iSchema :: Schema -- ^ The request schema. Can vary depending on profile headers. , iNegotiatedByProfile :: Bool -- ^ If schema was was chosen according to the profile spec https://www.w3.org/TR/dx-prof-conneg/ , iAcceptMediaType :: MediaType -- ^ The media type in the Accept header - , iBinaryField :: Maybe FieldName -- ^ field used for raw output + , iContentMediaType :: MediaType -- ^ The media type in the Content-Type header } -- | Examines HTTP request and translates it into user intent. -userApiRequest :: AppConfig -> SchemaCache -> Request -> RequestBody -> Either ApiRequestError ApiRequest -userApiRequest conf sCache req reqBody = do - pInfo <- getPathInfo conf $ pathInfo req +userApiRequest :: AppConfig -> Request -> RequestBody -> Either ApiRequestError ApiRequest +userApiRequest conf req reqBody = do + pInfo@PathInfo{..} <- getPathInfo conf $ pathInfo req act <- getAction pInfo method - qPrms <- first QueryParamError $ QueryParams.parse (pathIsProc pInfo && act `elem` [ActionInvoke InvGet, ActionInvoke InvHead]) $ rawQueryString req - mediaTypes <- getMediaTypes conf hdrs act pInfo - negotiatedSchema <- getSchema conf hdrs method - ranges <- getRanges method qPrms hdrs - apiRequest conf sCache req reqBody qPrms pInfo act mediaTypes negotiatedSchema ranges method hdrs + qPrms <- first QueryParamError $ QueryParams.parse (pathIsProc && act `elem` [ActionInvoke InvGet, ActionInvoke InvHead]) $ rawQueryString req + (acceptMediaType, contentMediaType) <- getMediaTypes conf hdrs act pInfo + (schema, negotiatedByProfile) <- getSchema conf hdrs method + (topLevelRange, ranges) <- getRanges method qPrms hdrs + (payload, columns) <- getPayload reqBody contentMediaType qPrms act pInfo + return $ ApiRequest { + iAction = act + , iTarget = if | pathIsProc -> TargetProc (QualifiedIdentifier schema pathName) pathIsRootSpec + | pathIsDefSpec -> TargetDefaultSpec schema + | otherwise -> TargetIdent $ QualifiedIdentifier schema pathName + , iRange = ranges + , iTopLevelRange = topLevelRange + , iPayload = payload + , iPreferRepresentation = fromMaybe None preferRepresentation + , iPreferParameters = preferParameters + , iPreferCount = preferCount + , iPreferResolution = preferResolution + , iPreferTransaction = preferTransaction + , iQueryParams = qPrms + , iColumns = columns + , iHeaders = iHdrs + , iCookies = iCkies + , iPath = rawPathInfo req + , iMethod = method + , iSchema = schema + , iNegotiatedByProfile = negotiatedByProfile + , iAcceptMediaType = acceptMediaType + , iContentMediaType = contentMediaType + } where method = requestMethod req hdrs = requestHeaders req + lookupHeader = flip lookup hdrs + Preferences.Preferences{..} = Preferences.fromHeaders hdrs + iHdrs = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie] + iCkies = maybe [] parseCookies $ lookupHeader "Cookie" getPathInfo :: AppConfig -> [Text] -> Either ApiRequestError PathInfo getPathInfo AppConfig{configOpenApiMode, configDbRootSpec} path = @@ -270,98 +264,52 @@ getRanges method QueryParams{qsOrder,qsRanges} hdrs isInvalidRange = topLevelRange == emptyRange && not (hasLimitZero limitRange) topLevelRange = fromMaybe allRange $ HM.lookup "limit" ranges -- if no limit is specified, get all the request rows -apiRequest :: AppConfig -> SchemaCache -> Request -> RequestBody -> QueryParams.QueryParams -> PathInfo -> Action -> - (MediaType, MediaType) -> (Schema, Bool) -> (NonnegRange, HM.HashMap Text NonnegRange) -> ByteString -> RequestHeaders -> - Either ApiRequestError ApiRequest -apiRequest conf sCache req reqBody queryparams@QueryParams{..} PathInfo{pathName, pathIsProc, pathIsRootSpec, pathIsDefSpec} action (acceptMediaType, contentMediaType) (schema, negotiatedByProfile) (topLevelRange, ranges) method hdrs - | shouldParsePayload && isLeft payload = either (Left . InvalidBody) witness payload - | otherwise = do - checkedTarget <- target - bField <- binaryField conf acceptMediaType checkedTarget queryparams - return ApiRequest { - iAction = action - , iTarget = checkedTarget - , iRange = ranges - , iTopLevelRange = topLevelRange - , iPayload = relevantPayload - , iPreferRepresentation = fromMaybe None preferRepresentation - , iPreferParameters = preferParameters - , iPreferCount = preferCount - , iPreferResolution = preferResolution - , iPreferTransaction = preferTransaction - , iQueryParams = queryparams - , iColumns = payloadColumns - , iHeaders = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie] - , iCookies = maybe [] parseCookies $ lookupHeader "Cookie" - , iPath = rawPathInfo req - , iMethod = method - , iSchema = schema - , iNegotiatedByProfile = negotiatedByProfile - , iAcceptMediaType = acceptMediaType - , iBinaryField = bField - } - where - columns = case action of - ActionMutate MutationCreate -> qsColumns - ActionMutate MutationUpdate -> qsColumns - ActionInvoke InvPost -> qsColumns - _ -> Nothing +getPayload :: RequestBody -> MediaType -> QueryParams.QueryParams -> Action -> PathInfo -> Either ApiRequestError (Maybe Payload, S.Set FieldName) +getPayload reqBody contentMediaType QueryParams{qsColumns} action PathInfo{pathIsProc}= do + checkedPayload <- if shouldParsePayload then payload else Right Nothing + let cols = case (checkedPayload, columns) of + (Just ProcessedJSON{payKeys}, _) -> payKeys + (Just ProcessedUrlEncoded{payKeys}, _) -> payKeys + (Just RawJSON{}, Just cls) -> cls + _ -> S.empty + return (checkedPayload, cols) + where + payload :: Either ApiRequestError (Maybe Payload) + payload = mapBoth InvalidBody Just $ case (contentMediaType, pathIsProc) of + (MTApplicationJSON, _) -> + if isJust columns + then Right $ RawJSON reqBody + else note "All object keys must match" . payloadAttributes reqBody + =<< if LBS.null reqBody && pathIsProc + then Right emptyObject + else first BS.pack $ JSON.eitherDecode reqBody + (MTTextCSV, _) -> do + json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody) + note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json + (MTUrlEncoded, isProc) -> do + let params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody) + if isProc + then Right $ ProcessedUrlEncoded params (S.fromList $ fst <$> params) + else + let paramsMap = HM.fromList $ (identity *** JSON.String) <$> params in + Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (HM.keys paramsMap) + (MTTextPlain, True) -> Right $ RawPay reqBody + (MTTextXML, True) -> Right $ RawPay reqBody + (MTOctetStream, True) -> Right $ RawPay reqBody + (ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct - payloadColumns = - case (contentMediaType, action) of - (_, ActionInvoke InvGet) -> S.fromList $ fst <$> qsParams - (_, ActionInvoke InvHead) -> S.fromList $ fst <$> qsParams - (MTUrlEncoded, _) -> S.fromList $ map (T.decodeUtf8 . fst) $ parseSimpleQuery $ LBS.toStrict reqBody - _ -> case (relevantPayload, columns) of - (Just ProcessedJSON{payKeys}, _) -> payKeys - (Just RawJSON{}, Just cls) -> cls - _ -> S.empty - payload :: Either ByteString Payload - payload = case (contentMediaType, pathIsProc) of - (MTApplicationJSON, _) -> - if isJust columns - then Right $ RawJSON reqBody - else note "All object keys must match" . payloadAttributes reqBody - =<< if LBS.null reqBody && pathIsProc - then Right emptyObject - else first BS.pack $ JSON.eitherDecode reqBody - (MTTextCSV, _) -> do - json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody) - note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json - (MTUrlEncoded, _) -> - let paramsMap = HM.fromList $ (T.decodeUtf8 *** JSON.String . T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody) in - Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (HM.keys paramsMap) - (MTTextPlain, True) -> Right $ RawPay reqBody - (MTTextXML, True) -> Right $ RawPay reqBody - (MTOctetStream, True) -> Right $ RawPay reqBody - (ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct + shouldParsePayload = case (action, contentMediaType) of + (ActionMutate MutationCreate, _) -> True + (ActionInvoke InvPost, _) -> True + (ActionMutate MutationSingleUpsert, _) -> True + (ActionMutate MutationUpdate, _) -> True + _ -> False - target - | pathIsProc = (`TargetProc` pathIsRootSpec) <$> callFindProc schema pathName - | pathIsDefSpec = Right $ TargetDefaultSpec schema - | otherwise = Right $ TargetIdent $ QualifiedIdentifier schema pathName - where - callFindProc procSch procNam = findProc - (QualifiedIdentifier procSch procNam) payloadColumns (preferParameters == Just SingleObject) (dbProcs sCache) - contentMediaType (action == ActionInvoke InvPost) - - shouldParsePayload = case (action, contentMediaType) of - (ActionMutate MutationCreate, _) -> True - (ActionInvoke InvPost, MTUrlEncoded) -> False - (ActionInvoke InvPost, _) -> True - (ActionMutate MutationSingleUpsert, _) -> True - (ActionMutate MutationUpdate, _) -> True - _ -> False - relevantPayload = case (contentMediaType, 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) qsParams - (_, ActionInvoke InvHead) -> targetToJsonRpcParams (rightToMaybe target) qsParams - (MTUrlEncoded, ActionInvoke InvPost) -> targetToJsonRpcParams (rightToMaybe target) $ (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody) - _ | shouldParsePayload -> rightToMaybe payload - | otherwise -> Nothing - lookupHeader = flip lookup hdrs - Preferences.Preferences{..} = Preferences.fromHeaders hdrs + columns = case action of + ActionMutate MutationCreate -> qsColumns + ActionMutate MutationUpdate -> qsColumns + ActionInvoke InvPost -> qsColumns + _ -> Nothing {-| Find the best match from a list of media types accepted by the @@ -450,92 +398,3 @@ requestMediaTypes conf action path = [MTApplicationJSON, MTSingularJSON, MTGeoJSON, MTTextCSV] ++ [MTPlan $ MTPlanAttrs Nothing PlanJSON mempty | configDbPlanEnabled conf] rawMediaTypes = configRawMediaTypes conf `union` [MTOctetStream, MTTextPlain, MTTextXML] - -{-| - Search a pg proc by matching name and arguments keys to parameters. Since a function can be overloaded, - the name is not enough to find it. An overloaded function can have a different volatility or even a different return type. --} -findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> MediaType -> Bool -> Either ApiRequestError ProcDescription -findProc qi argumentsKeys paramsAsSingleObject allProcs contentMediaType isInvPost = - case matchProc of - ([], []) -> Left $ NoRpc (qiSchema qi) (qiName qi) (S.toList argumentsKeys) paramsAsSingleObject contentMediaType isInvPost (HM.keys allProcs) lookupProcName - -- If there are no functions with named arguments, fallback to the single unnamed argument function - ([], [proc]) -> Right proc - ([], procs) -> Left $ AmbiguousRpc (toList procs) - -- Matches the functions with named arguments - ([proc], _) -> Right proc - (procs, _) -> Left $ AmbiguousRpc (toList procs) - where - matchProc = overloadedProcPartition lookupProcName - -- First find the proc by name - lookupProcName = HM.lookupDefault mempty qi allProcs - -- The partition obtained has the form (overloadedProcs,fallbackProcs) - -- where fallbackProcs are functions with a single unnamed parameter - overloadedProcPartition = foldr select ([],[]) - select proc ~(ts,fs) - | matchesParams proc = (proc:ts,fs) - | hasSingleUnnamedParam proc = (ts,proc:fs) - | otherwise = (ts,fs) - -- If the function is called with post and has a single unnamed parameter - -- it can be called depending on content type and the parameter type - hasSingleUnnamedParam ProcDescription{pdParams=[ProcParam{ppType}]} = isInvPost && case (contentMediaType, ppType) of - (MTApplicationJSON, "json") -> True - (MTApplicationJSON, "jsonb") -> True - (MTTextPlain, "text") -> True - (MTTextXML, "xml") -> True - (MTOctetStream, "bytea") -> True - _ -> False - hasSingleUnnamedParam _ = False - matchesParams proc = - let - params = pdParams proc - firstType = (ppType <$> headMay params) - in - -- exceptional case for Prefer: params=single-object - if paramsAsSingleObject - then length params == 1 && (firstType == Just "json" || firstType == Just "jsonb") - -- If the function has no parameters, the arguments keys must be empty as well - else if null params - then null argumentsKeys && not (isInvPost && contentMediaType `elem` [MTOctetStream, MTTextPlain, MTTextXML]) - -- A function has optional and required parameters. Optional parameters have a default value and - -- don't require arguments for the function to be executed, required parameters must have an argument present. - else case L.partition ppReq params of - -- If the function only has required parameters, the arguments keys must match those parameters - (reqParams, []) -> argumentsKeys == S.fromList (ppName <$> reqParams) - -- If the function only has optional parameters, the arguments keys can match none or any of them(a subset) - ([], optParams) -> argumentsKeys `S.isSubsetOf` S.fromList (ppName <$> optParams) - -- If the function has required and optional parameters, the arguments keys have to match the required parameters - -- and can match any or none of the default parameters. - (reqParams, optParams) -> argumentsKeys `S.difference` S.fromList (ppName <$> optParams) == S.fromList (ppName <$> reqParams) - --- | If raw(binary) output is requested, check that MediaType is one of the --- admitted rawMediaTypes and that`?select=...` contains only one field other --- than `*` -binaryField :: AppConfig -> MediaType -> Target -> QueryParams -> Either ApiRequestError (Maybe FieldName) -binaryField AppConfig{configRawMediaTypes} acceptMediaType target QueryParams{qsSelect} - | returnsScalar target && isRawMediaType = - Right $ Just "pgrst_scalar" - | isRawMediaType = - let - fieldName = fstFieldName qsSelect - in - case fieldName of - Just fld -> Right $ Just fld - Nothing -> Left $ BinaryFieldError acceptMediaType - | otherwise = - Right Nothing - where - isRawMediaType = acceptMediaType `elem` configRawMediaTypes `union` [MTOctetStream, MTTextPlain, MTTextXML] || isRawPlan acceptMediaType - isRawPlan mt = case mt of - MTPlan (MTPlanAttrs (Just MTOctetStream) _ _) -> True - MTPlan (MTPlanAttrs (Just MTTextPlain) _ _) -> True - MTPlan (MTPlanAttrs (Just MTTextXML) _ _) -> True - _ -> False - returnsScalar :: Target -> Bool - returnsScalar (TargetProc proc _) = procReturnsScalar proc - returnsScalar _ = False - - fstFieldName :: [Tree SelectItem] -> Maybe FieldName - fstFieldName [Node SelectField{selField=("*", _)} []] = Nothing - fstFieldName [Node SelectField{selField=(fld, _)} []] = Just fld - fstFieldName _ = Nothing diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index f8973f51c..03a1e82e6 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -147,7 +147,7 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@ apiRequest <- liftEither . mapLeft Error.ApiRequestError $ - ApiRequest.userApiRequest conf sCache req body + ApiRequest.userApiRequest conf req body Response.optionalRollback conf apiRequest $ handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache @@ -172,8 +172,8 @@ handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache = case (iAction, iTarget) of (ActionRead headersOnly, TargetIdent identifier) -> do - rPlan <- liftEither $ Plan.readPlan identifier conf sCache apiReq - resultSet <- runQuery Plan.readPlanTxMode $ Query.readQuery rPlan conf apiReq + wrPlan <- liftEither $ Plan.wrappedReadPlan identifier conf sCache apiReq + resultSet <- runQuery (Plan.wrTxMode wrPlan) $ Query.readQuery wrPlan conf apiReq return $ Response.readResponse headersOnly identifier apiReq resultSet (ActionMutate MutationCreate, TargetIdent identifier) -> do @@ -196,10 +196,10 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A resultSet <- runQuery (Plan.mrTxMode mrPlan) $ Query.deleteQuery mrPlan apiReq conf return $ Response.deleteResponse apiReq resultSet - (ActionInvoke invMethod, TargetProc proc _) -> do - cPlan <- liftEither $ Plan.callReadPlan proc conf sCache apiReq invMethod - resultSet <- runQuery (Plan.crTxMode cPlan) $ Query.invokeQuery proc cPlan apiReq conf - return $ Response.invokeResponse invMethod proc apiReq resultSet + (ActionInvoke invMethod, TargetProc identifier _) -> do + cPlan <- liftEither $ Plan.callReadPlan identifier conf sCache apiReq invMethod + resultSet <- runQuery (Plan.crTxMode cPlan) $ Query.invokeQuery (Plan.crProc cPlan) cPlan apiReq conf + return $ Response.invokeResponse invMethod (Plan.crProc cPlan) apiReq resultSet (ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do oaiResult <- runQuery Plan.inspectPlanTxMode $ Query.openApiQuery sCache pgVer conf tSchema @@ -208,8 +208,9 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A (ActionInfo, TargetIdent identifier) -> return $ Response.infoIdentResponse identifier sCache - (ActionInfo, TargetProc proc _) -> - return $ Response.infoProcResponse proc + (ActionInfo, TargetProc identifier _) -> do + cPlan <- liftEither $ Plan.callReadPlan identifier conf sCache apiReq ApiRequest.InvHead + return $ Response.infoProcResponse (Plan.crProc cPlan) (ActionInfo, TargetDefaultSpec _) -> return Response.infoRootResponse diff --git a/src/PostgREST/Plan.hs b/src/PostgREST/Plan.hs index 8f800df06..26faa833b 100644 --- a/src/PostgREST/Plan.hs +++ b/src/PostgREST/Plan.hs @@ -16,16 +16,19 @@ resource. {-# LANGUAGE RecordWildCards #-} module PostgREST.Plan - ( readPlan + ( wrappedReadPlan , mutateReadPlan , callReadPlan + , WrappedReadPlan(..) , MutateReadPlan(..) , CallReadPlan(..) - , readPlanTxMode , inspectPlanTxMode ) where + +import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HM +import qualified Data.List as L import qualified Data.Set as S import qualified PostgREST.SchemaCache.Proc as Proc @@ -40,6 +43,8 @@ import PostgREST.ApiRequest (Action (..), Payload (..)) import PostgREST.Config (AppConfig (..)) import PostgREST.Error (Error (..)) +import PostgREST.MediaType (MTPlanAttrs (..), + MediaType (..)) import PostgREST.Query.SqlFragment (sourceCTEName) import PostgREST.RangeQuery (NonnegRange, allRange, convertToLimitZeroRange, @@ -49,7 +54,7 @@ import PostgREST.SchemaCache.Identifiers (FieldName, QualifiedIdentifier (..), Schema) import PostgREST.SchemaCache.Proc (ProcDescription (..), - ProcParam (..), + ProcParam (..), ProcsMap, procReturnsScalar) import PostgREST.SchemaCache.Relationship (Cardinality (..), Junction (..), @@ -71,6 +76,12 @@ import qualified PostgREST.ApiRequest.QueryParams as QueryParams import Protolude hiding (from) +data WrappedReadPlan = WrappedReadPlan { + wrReadPlan :: ReadPlanTree +, wrTxMode :: SQL.Mode +, wrBinField :: Maybe FieldName +} + data MutateReadPlan = MutateReadPlan { mrReadPlan :: ReadPlanTree , mrMutatePlan :: MutatePlan @@ -81,29 +92,105 @@ data CallReadPlan = CallReadPlan { crReadPlan :: ReadPlanTree , crCallPlan :: CallPlan , crTxMode :: SQL.Mode +, crProc :: ProcDescription +, crBinField :: Maybe FieldName } +wrappedReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> Either Error WrappedReadPlan +wrappedReadPlan identifier conf sCache apiRequest = do + rPlan <- readPlan identifier conf sCache apiRequest + binField <- mapLeft ApiRequestError $ binaryField conf (iAcceptMediaType apiRequest) Nothing rPlan + return $ WrappedReadPlan rPlan SQL.Read binField + mutateReadPlan :: Mutation -> ApiRequest -> QualifiedIdentifier -> AppConfig -> SchemaCache -> Either Error MutateReadPlan mutateReadPlan mutation apiRequest identifier conf sCache = do rPlan <- readPlan identifier conf sCache apiRequest mPlan <- mutatePlan mutation identifier apiRequest sCache rPlan return $ MutateReadPlan rPlan mPlan SQL.Write -callReadPlan :: ProcDescription -> AppConfig -> SchemaCache -> ApiRequest -> InvokeMethod -> Either Error CallReadPlan -callReadPlan proc conf sCache apiRequest invMethod = do - let identifier = QualifiedIdentifier (pdSchema proc) (fromMaybe (pdName proc) $ Proc.procTableName proc) - rPlan <- readPlan identifier conf sCache apiRequest - let cPlan = callPlan proc apiRequest rPlan - txMode = case (invMethod, Proc.pdVolatility proc) of +callReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> InvokeMethod -> Either Error CallReadPlan +callReadPlan identifier conf sCache apiRequest invMethod = do + let paramKeys = case invMethod of + InvGet -> S.fromList $ fst <$> qsParams' + InvHead -> S.fromList $ fst <$> qsParams' + InvPost -> iColumns apiRequest + proc@ProcDescription{..} <- mapLeft ApiRequestError $ + findProc identifier paramKeys (iPreferParameters apiRequest == Just SingleObject) (dbProcs sCache) (iContentMediaType apiRequest) (invMethod == InvPost) + let relIdentifier = QualifiedIdentifier pdSchema (fromMaybe pdName $ Proc.procTableName proc) -- done so a set returning function can embed other relations + rPlan <- readPlan relIdentifier conf sCache apiRequest + let args = case (invMethod, iContentMediaType apiRequest) of + (InvGet, _) -> jsonRpcParams proc qsParams' + (InvHead, _) -> jsonRpcParams proc qsParams' + (InvPost, MTUrlEncoded) -> maybe mempty (jsonRpcParams proc . payArray) $ iPayload apiRequest + (InvPost, _) -> maybe mempty payRaw $ iPayload apiRequest + txMode = case (invMethod, pdVolatility) of (InvGet, _) -> SQL.Read (InvHead, _) -> SQL.Read (InvPost, Proc.Stable) -> SQL.Read (InvPost, Proc.Immutable) -> SQL.Read (InvPost, Proc.Volatile) -> SQL.Write - return $ CallReadPlan rPlan cPlan txMode + cPlan = callPlan proc apiRequest paramKeys args rPlan + binField <- mapLeft ApiRequestError $ binaryField conf (iAcceptMediaType apiRequest) (Just proc) rPlan + return $ CallReadPlan rPlan cPlan txMode proc binField + where + qsParams' = QueryParams.qsParams (iQueryParams apiRequest) -readPlanTxMode :: SQL.Mode -readPlanTxMode = SQL.Read +{-| + Search a pg proc by matching name and arguments keys to parameters. Since a function can be overloaded, + the name is not enough to find it. An overloaded function can have a different volatility or even a different return type. +-} +findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> MediaType -> Bool -> Either ApiRequestError ProcDescription +findProc qi argumentsKeys paramsAsSingleObject allProcs contentMediaType isInvPost = + case matchProc of + ([], []) -> Left $ NoRpc (qiSchema qi) (qiName qi) (S.toList argumentsKeys) paramsAsSingleObject contentMediaType isInvPost (HM.keys allProcs) lookupProcName + -- If there are no functions with named arguments, fallback to the single unnamed argument function + ([], [proc]) -> Right proc + ([], procs) -> Left $ AmbiguousRpc (toList procs) + -- Matches the functions with named arguments + ([proc], _) -> Right proc + (procs, _) -> Left $ AmbiguousRpc (toList procs) + where + matchProc = overloadedProcPartition lookupProcName + -- First find the proc by name + lookupProcName = HM.lookupDefault mempty qi allProcs + -- The partition obtained has the form (overloadedProcs,fallbackProcs) + -- where fallbackProcs are functions with a single unnamed parameter + overloadedProcPartition = foldr select ([],[]) + select proc ~(ts,fs) + | matchesParams proc = (proc:ts,fs) + | hasSingleUnnamedParam proc = (ts,proc:fs) + | otherwise = (ts,fs) + -- If the function is called with post and has a single unnamed parameter + -- it can be called depending on content type and the parameter type + hasSingleUnnamedParam ProcDescription{pdParams=[ProcParam{ppType}]} = isInvPost && case (contentMediaType, ppType) of + (MTApplicationJSON, "json") -> True + (MTApplicationJSON, "jsonb") -> True + (MTTextPlain, "text") -> True + (MTTextXML, "xml") -> True + (MTOctetStream, "bytea") -> True + _ -> False + hasSingleUnnamedParam _ = False + matchesParams proc = + let + params = pdParams proc + firstType = (ppType <$> headMay params) + in + -- exceptional case for Prefer: params=single-object + if paramsAsSingleObject + then length params == 1 && (firstType == Just "json" || firstType == Just "jsonb") + -- If the function has no parameters, the arguments keys must be empty as well + else if null params + then null argumentsKeys && not (isInvPost && contentMediaType `elem` [MTOctetStream, MTTextPlain, MTTextXML]) + -- A function has optional and required parameters. Optional parameters have a default value and + -- don't require arguments for the function to be executed, required parameters must have an argument present. + else case L.partition ppReq params of + -- If the function only has required parameters, the arguments keys must match those parameters + (reqParams, []) -> argumentsKeys == S.fromList (ppName <$> reqParams) + -- If the function only has optional parameters, the arguments keys can match none or any of them(a subset) + ([], optParams) -> argumentsKeys `S.isSubsetOf` S.fromList (ppName <$> optParams) + -- If the function has required and optional parameters, the arguments keys have to match the required parameters + -- and can match any or none of the default parameters. + (reqParams, optParams) -> argumentsKeys `S.difference` S.fromList (ppName <$> optParams) == S.fromList (ppName <$> reqParams) inspectPlanTxMode :: SQL.Mode inspectPlanTxMode = SQL.Read @@ -452,23 +539,23 @@ resolveOrError (Just table) field = Nothing -> Left $ ColumnNotFound (tableName table) field Just typedField -> Right typedField -callPlan :: ProcDescription -> ApiRequest -> ReadPlanTree -> CallPlan -callPlan proc apiReq readReq = FunctionCall { +callPlan :: ProcDescription -> ApiRequest -> S.Set FieldName -> LBS.ByteString -> ReadPlanTree -> CallPlan +callPlan proc apiReq paramKeys args readReq = FunctionCall { funCQi = QualifiedIdentifier (pdSchema proc) (pdName proc) , funCParams = callParams -, funCArgs = payRaw <$> iPayload apiReq +, funCArgs = Just args , funCScalar = procReturnsScalar proc , funCMultipleCall = iPreferParameters apiReq == Just MultipleObjects , funCReturning = inferColsEmbedNeeds readReq [] } where paramsAsSingleObject = iPreferParameters apiReq == Just SingleObject + specifiedParams = filter (\x -> ppName x `S.member` paramKeys) callParams = case pdParams proc of [prm] | paramsAsSingleObject -> OnePosParam prm | ppName prm == mempty -> OnePosParam prm | otherwise -> KeyParams $ specifiedParams [prm] prms -> KeyParams $ specifiedParams prms - specifiedParams = filter (\x -> ppName x `S.member` iColumns apiReq) -- | Infers the columns needed for an embed to be successful after a mutation or a function call. inferColsEmbedNeeds :: ReadPlanTree -> [FieldName] -> [FieldName] @@ -519,3 +606,33 @@ inferColsEmbedNeeds (Node ReadPlan{select} forest) pkCols -- they are later concatenated with AND in the QueryBuilder addFilterToLogicForest :: Filter -> [LogicTree] -> [LogicTree] addFilterToLogicForest flt lf = Stmnt flt : lf + +-- | If raw(binary) output is requested, check that MediaType is one of the +-- admitted rawMediaTypes and that`?select=...` contains only one field other +-- than `*` +binaryField :: AppConfig -> MediaType -> Maybe ProcDescription -> ReadPlanTree -> Either ApiRequestError (Maybe FieldName) +binaryField AppConfig{configRawMediaTypes} acceptMediaType proc rpTree + | isRawMediaType = + if (procReturnsScalar <$> proc) == Just True + then Right $ Just "pgrst_scalar" + else + let + fieldName = fstFieldName rpTree + in + case fieldName of + Just fld -> Right $ Just fld + Nothing -> Left $ BinaryFieldError acceptMediaType + | otherwise = + Right Nothing + where + isRawMediaType = acceptMediaType `elem` configRawMediaTypes `L.union` [MTOctetStream, MTTextPlain, MTTextXML] || isRawPlan acceptMediaType + isRawPlan mt = case mt of + MTPlan (MTPlanAttrs (Just MTOctetStream) _ _) -> True + MTPlan (MTPlanAttrs (Just MTTextPlain) _ _) -> True + MTPlan (MTPlanAttrs (Just MTTextXML) _ _) -> True + _ -> False + + fstFieldName :: ReadPlanTree -> Maybe FieldName + fstFieldName (Node ReadPlan{select=(("*", []), _, _):_} []) = Nothing + fstFieldName (Node ReadPlan{select=[((fld, []), _, _)]} []) = Just fld + fstFieldName _ = Nothing diff --git a/src/PostgREST/Plan/CallPlan.hs b/src/PostgREST/Plan/CallPlan.hs index 743216eed..12d99fedc 100644 --- a/src/PostgREST/Plan/CallPlan.hs +++ b/src/PostgREST/Plan/CallPlan.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE NamedFieldPuns #-} module PostgREST.Plan.CallPlan ( CallPlan(..) , CallParams(..) + , jsonRpcParams ) where +import qualified Data.Aeson as JSON import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM import PostgREST.SchemaCache.Identifiers (FieldName, QualifiedIdentifier) -import PostgREST.SchemaCache.Proc (ProcParam (..)) +import PostgREST.SchemaCache.Proc (ProcDescription (..), + ProcParam (..)) import Protolude @@ -23,3 +28,29 @@ data CallPlan = FunctionCall data CallParams = KeyParams [ProcParam] -- ^ Call with key params: func(a := val1, b:= val2) | OnePosParam ProcParam -- ^ Call with positional params(only one supported): func(val) + +-- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"} +jsonRpcParams :: ProcDescription -> [(Text, Text)] -> LBS.ByteString +jsonRpcParams proc prms = + if not $ pdHasVariadic proc then -- if proc has no variadic param, save steps and directly convert to json + JSON.encode $ HM.fromList $ second JSON.toJSON <$> prms + else + let paramsMap = HM.fromListWith mergeParams $ toRpcParamValue proc <$> prms in + JSON.encode paramsMap + where + mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue + mergeParams (Variadic a) (Variadic b) = Variadic $ b ++ a + mergeParams v _ = v -- repeated params for non-variadic parameters are not merged + +toRpcParamValue :: ProcDescription -> (Text, Text) -> (Text, RpcParamValue) +toRpcParamValue proc (k, v) | prmIsVariadic k = (k, Variadic [v]) + | otherwise = (k, Fixed v) + where + prmIsVariadic prm = isJust $ find (\ProcParam{ppName, ppVar} -> ppName == prm && ppVar) $ pdParams proc + +-- | RPC query param value `/rpc/func?v=`, used for VARIADIC functions on form-urlencoded POST and GETs +-- | It can be fixed `?v=1` or repeated `?v=1&v=2&v=3. +data RpcParamValue = Fixed Text | Variadic [Text] +instance JSON.ToJSON RpcParamValue where + toJSON (Fixed v) = JSON.toJSON v + toJSON (Variadic v) = JSON.toJSON v diff --git a/src/PostgREST/Query.hs b/src/PostgREST/Query.hs index b48ca98f4..d16a214e3 100644 --- a/src/PostgREST/Query.hs +++ b/src/PostgREST/Query.hs @@ -46,9 +46,9 @@ import PostgREST.Config.PgVersion (PgVersion (..), import PostgREST.Error (Error) import PostgREST.MediaType (MediaType (..)) import PostgREST.Plan (CallReadPlan (..), - MutateReadPlan (..)) + MutateReadPlan (..), + WrappedReadPlan (..)) import PostgREST.Plan.MutatePlan (MutatePlan (..)) -import PostgREST.Plan.ReadPlan (ReadPlanTree) import PostgREST.Query.SqlFragment (fromQi, intercalateSnippet, pgFmtIdentList, setConfigLocal, @@ -65,13 +65,13 @@ import Protolude hiding (Handler) type DbHandler = ExceptT Error SQL.Transaction -readQuery :: ReadPlanTree -> AppConfig -> ApiRequest -> DbHandler ResultSet -readQuery req conf@AppConfig{..} apiReq@ApiRequest{..} = do - let countQuery = QueryBuilder.readPlanToCountQuery req +readQuery :: WrappedReadPlan -> AppConfig -> ApiRequest -> DbHandler ResultSet +readQuery WrappedReadPlan{wrReadPlan, wrBinField} conf@AppConfig{..} apiReq@ApiRequest{..} = do + let countQuery = QueryBuilder.readPlanToCountQuery wrReadPlan resultSet <- lift . SQL.statement mempty $ Statements.prepareRead - (QueryBuilder.readPlanToQuery req) + (QueryBuilder.readPlanToQuery wrReadPlan) (if iPreferCount == Just EstimatedCount then -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed QueryBuilder.limitedQuery countQuery ((+ 1) <$> configDbMaxRows) @@ -80,7 +80,7 @@ readQuery req conf@AppConfig{..} apiReq@ApiRequest{..} = do ) (shouldCount iPreferCount) iAcceptMediaType - iBinaryField + wrBinField configDbPreparedStatements failNotSingular iAcceptMediaType resultSet optionalRollback conf apiReq @@ -151,7 +151,7 @@ deleteQuery mrPlan apiReq@ApiRequest{..} conf = do pure resultSet invokeQuery :: ProcDescription -> CallReadPlan -> ApiRequest -> AppConfig -> DbHandler ResultSet -invokeQuery proc CallReadPlan{crReadPlan, crCallPlan} apiReq@ApiRequest{..} conf@AppConfig{..} = do +invokeQuery proc CallReadPlan{crReadPlan, crCallPlan, crBinField} apiReq@ApiRequest{..} conf@AppConfig{..} = do resultSet <- lift . SQL.statement mempty $ Statements.prepareCall @@ -163,7 +163,7 @@ invokeQuery proc CallReadPlan{crReadPlan, crCallPlan} apiReq@ApiRequest{..} conf (shouldCount iPreferCount) iAcceptMediaType (iPreferParameters == Just MultipleObjects) - iBinaryField + crBinField configDbPreparedStatements optionalRollback conf apiReq