489 lines
24 KiB
Haskell
489 lines
24 KiB
Haskell
{-|
|
|
Module : PostgREST.Request.ApiRequest
|
|
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
|
|
-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module PostgREST.Request.ApiRequest
|
|
( ApiRequest(..)
|
|
, InvokeMethod(..)
|
|
, Mutation(..)
|
|
, MediaType(..)
|
|
, Action(..)
|
|
, Target(..)
|
|
, Payload(..)
|
|
, userApiRequest
|
|
) where
|
|
|
|
import qualified Data.Aeson as JSON
|
|
import qualified Data.Aeson.Key as K
|
|
import qualified Data.Aeson.KeyMap as KM
|
|
import qualified Data.ByteString.Char8 as BS
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Csv as CSV
|
|
import qualified Data.HashMap.Strict as HM
|
|
import qualified Data.List as L
|
|
import qualified Data.List.NonEmpty as NonEmptyList
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.Set as S
|
|
import qualified Data.Text.Encoding as T
|
|
import qualified Data.Vector as V
|
|
|
|
import Control.Arrow ((***))
|
|
import Data.Aeson.Types (emptyArray, emptyObject)
|
|
import Data.List (lookup, union)
|
|
import Data.Maybe (fromJust)
|
|
import Data.Ranged.Ranges (emptyRange, rangeIntersection)
|
|
import Network.HTTP.Types.Header (hCookie)
|
|
import Network.HTTP.Types.URI (parseSimpleQuery)
|
|
import Network.Wai (Request (..))
|
|
import Network.Wai.Parse (parseHttpAccept)
|
|
import Web.Cookie (parseCookies)
|
|
|
|
import PostgREST.Config (AppConfig (..),
|
|
OpenAPIMode (..))
|
|
import PostgREST.DbStructure (DbStructure (..))
|
|
import PostgREST.DbStructure.Identifiers (FieldName,
|
|
QualifiedIdentifier (..),
|
|
Schema)
|
|
import PostgREST.DbStructure.Proc (ProcDescription (..),
|
|
ProcParam (..), ProcsMap)
|
|
import PostgREST.MediaType (MTPlanAttrs (..),
|
|
MTPlanFormat (..),
|
|
MediaType (..))
|
|
import PostgREST.RangeQuery (NonnegRange, allRange,
|
|
hasLimitZero,
|
|
limitZeroRange,
|
|
rangeRequested)
|
|
import PostgREST.Request.Preferences (PreferCount (..),
|
|
PreferParameters (..),
|
|
PreferRepresentation (..),
|
|
PreferResolution (..),
|
|
PreferTransaction (..))
|
|
import PostgREST.Request.QueryParams (QueryParams (..))
|
|
import PostgREST.Request.Types (ApiRequestError (..))
|
|
|
|
import qualified PostgREST.MediaType as MediaType
|
|
import qualified PostgREST.Request.Preferences as Preferences
|
|
import qualified PostgREST.Request.QueryParams as QueryParams
|
|
|
|
import Protolude
|
|
|
|
|
|
type RequestBody = LBS.ByteString
|
|
|
|
data Payload
|
|
= ProcessedJSON -- ^ Cached attributes of a JSON payload
|
|
{ payRaw :: LBS.ByteString
|
|
-- ^ This is the raw ByteString that comes from the request body. We
|
|
-- cache this instead of an Aeson Value because it was detected that for
|
|
-- large payloads the encoding had high memory usage, see
|
|
-- https://github.com/PostgREST/postgrest/pull/1005 for more details
|
|
, payKeys :: S.Set Text
|
|
-- ^ Keys of the object or if it's an array these keys are guaranteed to
|
|
-- be the same across all its objects
|
|
}
|
|
| RawJSON { payRaw :: LBS.ByteString }
|
|
| RawPay { payRaw :: LBS.ByteString }
|
|
|
|
data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
|
|
data Mutation = MutationCreate | MutationDelete | MutationSingleUpsert | MutationUpdate deriving Eq
|
|
|
|
-- | Types of things a user wants to do to tables/views/procs
|
|
data Action
|
|
= ActionMutate Mutation
|
|
| ActionRead {isHead :: Bool}
|
|
| ActionInvoke InvokeMethod
|
|
| ActionInfo
|
|
| ActionInspect {isHead :: Bool}
|
|
deriving Eq
|
|
-- | The path info that will be mapped to a target (used to handle validations and errors before defining the Target)
|
|
data PathInfo
|
|
= PathInfo
|
|
{ pathName :: Text
|
|
, pathIsProc :: Bool
|
|
, pathIsDefSpec :: Bool
|
|
, pathIsRootSpec :: Bool
|
|
}
|
|
-- | The target db object of a user action
|
|
data Target = TargetIdent QualifiedIdentifier
|
|
| TargetProc{tProc :: ProcDescription, tpIsRootSpec :: Bool}
|
|
| TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/"
|
|
|
|
-- | RPC query param value `/rpc/func?v=<value>`, 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
|
|
specific language. There is no guarantee that the intent is
|
|
sensible, it is up to a later stage of processing to determine
|
|
if it is an action we are able to perform.
|
|
-}
|
|
data ApiRequest = ApiRequest {
|
|
iAction :: Action -- ^ Similar but not identical to HTTP method, e.g. Create/Invoke both POST
|
|
, iRange :: HM.HashMap Text NonnegRange -- ^ Requested range of rows within response
|
|
, iTopLevelRange :: NonnegRange -- ^ Requested range of rows from the top level
|
|
, iTarget :: Target -- ^ The target, be it calling a proc or accessing a table
|
|
, iPayload :: Maybe Payload -- ^ Data sent by client and used for mutation actions
|
|
, iPreferRepresentation :: PreferRepresentation -- ^ If client wants created items echoed back
|
|
, iPreferParameters :: Maybe PreferParameters -- ^ How to pass parameters to a stored procedure
|
|
, 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
|
|
, iQueryParams :: QueryParams.QueryParams
|
|
, iColumns :: S.Set FieldName -- ^ parsed colums from &columns parameter and payload
|
|
, iHeaders :: [(ByteString, ByteString)] -- ^ HTTP request headers
|
|
, iCookies :: [(ByteString, ByteString)] -- ^ Request Cookies
|
|
, iPath :: ByteString -- ^ Raw request path
|
|
, iMethod :: ByteString -- ^ Raw request method
|
|
, iProfile :: Maybe Schema -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/.
|
|
, iSchema :: Schema -- ^ The request schema. Can vary depending on iProfile.
|
|
, iAcceptMediaType :: MediaType
|
|
}
|
|
|
|
-- | Examines HTTP request and translates it into user intent.
|
|
userApiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest
|
|
userApiRequest conf dbStructure req reqBody = do
|
|
qPrms <- first QueryParamError $ QueryParams.parse $ rawQueryString req
|
|
pInfo <- getPathInfo conf $ pathInfo req
|
|
act <- getAction pInfo $ requestMethod req
|
|
apiRequest conf dbStructure req reqBody qPrms pInfo act
|
|
|
|
getPathInfo :: AppConfig -> [Text] -> Either ApiRequestError PathInfo
|
|
getPathInfo AppConfig{configOpenApiMode, configDbRootSpec} path =
|
|
case path of
|
|
[] -> case configDbRootSpec of
|
|
Just (QualifiedIdentifier _ pathName) -> Right $ PathInfo pathName True False True
|
|
Nothing | configOpenApiMode == OADisabled -> Left NotFound
|
|
| otherwise -> Right $ PathInfo mempty False True False
|
|
[table] -> Right $ PathInfo table False False False
|
|
["rpc", pName] -> Right $ PathInfo pName True False False
|
|
_ -> Left NotFound
|
|
|
|
getAction :: PathInfo -> ByteString -> Either ApiRequestError Action
|
|
getAction PathInfo{pathIsProc, pathIsDefSpec} method =
|
|
if pathIsProc && method `notElem` ["HEAD", "GET", "POST", "OPTIONS"]
|
|
then Left $ InvalidRpcMethod method
|
|
else case method of
|
|
-- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response
|
|
-- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4
|
|
"HEAD" | pathIsDefSpec -> Right $ ActionInspect{isHead=True}
|
|
| pathIsProc -> Right $ ActionInvoke InvHead
|
|
| otherwise -> Right $ ActionRead{isHead=True}
|
|
"GET" | pathIsDefSpec -> Right $ ActionInspect{isHead=False}
|
|
| pathIsProc -> Right $ ActionInvoke InvGet
|
|
| otherwise -> Right $ ActionRead{isHead=False}
|
|
"POST" | pathIsProc -> Right $ ActionInvoke InvPost
|
|
| otherwise -> Right $ ActionMutate MutationCreate
|
|
"PATCH" -> Right $ ActionMutate MutationUpdate
|
|
"PUT" -> Right $ ActionMutate MutationSingleUpsert
|
|
"DELETE" -> Right $ ActionMutate MutationDelete
|
|
"OPTIONS" -> Right ActionInfo
|
|
_ -> Left $ UnsupportedMethod method
|
|
|
|
apiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> QueryParams.QueryParams -> PathInfo -> Action -> Either ApiRequestError ApiRequest
|
|
apiRequest conf@AppConfig{..} dbStructure req reqBody queryparams@QueryParams{..} path@PathInfo{pathName, pathIsProc, pathIsRootSpec, pathIsDefSpec} action
|
|
| isJust profile && fromJust profile `notElem` configDbSchemas = Left $ UnacceptableSchema $ toList configDbSchemas
|
|
| isInvalidRange = Left InvalidRange
|
|
| shouldParsePayload && isLeft payload = either (Left . InvalidBody) witness payload
|
|
| not expectParams && not (L.null qsParams) = Left $ ParseRequestError "Unexpected param or filter missing operator" ("Failed to parse " <> show qsParams)
|
|
| method `elem` ["PATCH", "DELETE"] && not (null qsRanges) && null qsOrder = Left LimitNoOrderError
|
|
| method == "PUT" && topLevelRange /= allRange = Left PutRangeNotAllowedError
|
|
| otherwise = do
|
|
acceptMediaType <- findAcceptMediaType conf action path accepts
|
|
checkedTarget <- target
|
|
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
|
|
, iProfile = profile
|
|
, iSchema = schema
|
|
, iAcceptMediaType = acceptMediaType
|
|
}
|
|
where
|
|
accepts = maybe [MTAny] (map MediaType.decodeMediaType . parseHttpAccept) $ lookupHeader "accept"
|
|
|
|
expectParams = pathIsProc && method /= "POST"
|
|
|
|
contentMediaType = maybe MTApplicationJSON MediaType.decodeMediaType $ lookupHeader "content-type"
|
|
|
|
columns = case action of
|
|
ActionMutate MutationCreate -> qsColumns
|
|
ActionMutate MutationUpdate -> qsColumns
|
|
ActionInvoke InvPost -> qsColumns
|
|
_ -> Nothing
|
|
|
|
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
|
|
topLevelRange = fromMaybe allRange $ HM.lookup "limit" ranges -- if no limit is specified, get all the request rows
|
|
|
|
defaultSchema = NonEmptyList.head configDbSchemas
|
|
profile
|
|
| length configDbSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config
|
|
= Nothing
|
|
| otherwise = case method of
|
|
-- POST/PATCH/PUT/DELETE don't use the same header as per the spec
|
|
"DELETE" -> contentProfile
|
|
"PATCH" -> contentProfile
|
|
"POST" -> contentProfile
|
|
"PUT" -> contentProfile
|
|
_ -> acceptProfile
|
|
where
|
|
contentProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Content-Profile"
|
|
acceptProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Accept-Profile"
|
|
|
|
schema = fromMaybe defaultSchema profile
|
|
|
|
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 dbStructure)
|
|
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
|
|
method = requestMethod req
|
|
hdrs = requestHeaders req
|
|
lookupHeader = flip lookup hdrs
|
|
Preferences.Preferences{..} = Preferences.fromHeaders hdrs
|
|
headerRange = rangeRequested hdrs
|
|
limitRange = fromMaybe allRange (HM.lookup "limit" qsRanges)
|
|
headerAndLimitRange = rangeIntersection headerRange limitRange
|
|
|
|
-- Bypass all the ranges and send only the limit zero range (0 <= x <= -1) if
|
|
-- limit=0 is present in the query params (not allowed for the Range header)
|
|
ranges = HM.insert "limit" (if hasLimitZero limitRange then limitZeroRange else headerAndLimitRange) qsRanges
|
|
-- The only emptyRange allowed is the limit zero range
|
|
isInvalidRange = topLevelRange == emptyRange && not (hasLimitZero limitRange)
|
|
|
|
{-|
|
|
Find the best match from a list of media types accepted by the
|
|
client in order of decreasing preference and a list of types
|
|
producible by the server. If there is no match but the client
|
|
accepts */* then return the top server pick.
|
|
-}
|
|
mutuallyAgreeable :: [MediaType] -> [MediaType] -> Maybe MediaType
|
|
mutuallyAgreeable sProduces cAccepts =
|
|
let exact = listToMaybe $ L.intersect cAccepts sProduces in
|
|
if isNothing exact && MTAny `elem` cAccepts
|
|
then listToMaybe sProduces
|
|
else exact
|
|
|
|
type CsvData = V.Vector (M.Map Text LBS.ByteString)
|
|
|
|
{-|
|
|
Converts CSV like
|
|
a,b
|
|
1,hi
|
|
2,bye
|
|
|
|
into a JSON array like
|
|
[ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]
|
|
|
|
The reason for its odd signature is so that it can compose
|
|
directly with CSV.decodeByName
|
|
-}
|
|
csvToJson :: (CSV.Header, CsvData) -> JSON.Value
|
|
csvToJson (_, vals) =
|
|
JSON.Array $ V.map rowToJsonObj vals
|
|
where
|
|
rowToJsonObj = JSON.Object . KM.fromMapText .
|
|
M.map (\str ->
|
|
if str == "NULL"
|
|
then JSON.Null
|
|
else JSON.String . T.decodeUtf8 $ LBS.toStrict str
|
|
)
|
|
|
|
payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload
|
|
payloadAttributes raw json =
|
|
-- Test that Array contains only Objects having the same keys
|
|
case json of
|
|
JSON.Array arr ->
|
|
case arr V.!? 0 of
|
|
Just (JSON.Object o) ->
|
|
let canonicalKeys = S.fromList $ K.toText <$> KM.keys o
|
|
areKeysUniform = all (\case
|
|
JSON.Object x -> S.fromList (K.toText <$> KM.keys x) == canonicalKeys
|
|
_ -> False) arr in
|
|
if areKeysUniform
|
|
then Just $ ProcessedJSON raw canonicalKeys
|
|
else Nothing
|
|
Just _ -> Nothing
|
|
Nothing -> Just emptyPJArray
|
|
|
|
JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ K.toText <$> KM.keys o)
|
|
|
|
-- truncate everything else to an empty array.
|
|
_ -> Just emptyPJArray
|
|
where
|
|
emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty
|
|
|
|
findAcceptMediaType :: AppConfig -> Action -> PathInfo -> [MediaType] -> Either ApiRequestError MediaType
|
|
findAcceptMediaType conf action path accepts =
|
|
case mutuallyAgreeable (requestMediaTypes conf action path) accepts of
|
|
Just ct ->
|
|
Right ct
|
|
Nothing ->
|
|
Left . MediaTypeError $ map MediaType.toMime accepts
|
|
|
|
requestMediaTypes :: AppConfig -> Action -> PathInfo -> [MediaType]
|
|
requestMediaTypes conf action path =
|
|
case action of
|
|
ActionRead _ -> defaultMediaTypes ++ rawMediaTypes
|
|
ActionInvoke _ -> invokeMediaTypes
|
|
ActionInspect _ -> [MTOpenAPI, MTApplicationJSON]
|
|
ActionInfo -> [MTTextCSV]
|
|
_ -> defaultMediaTypes
|
|
where
|
|
invokeMediaTypes =
|
|
defaultMediaTypes
|
|
++ rawMediaTypes
|
|
++ [MTOpenAPI | pathIsRootSpec path]
|
|
defaultMediaTypes =
|
|
[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
|
|
-- 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 $ HM.lookupDefault mempty qi allProcs -- first find the proc by name
|
|
-- 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)
|