steve-chavez
6475f254f7
* Don't apply `tx=commit` if the transaction doesn't commit * Apply `count=exact` * Also simplifies the Preference-Applied logic, removing the need for some functions.
380 lines
18 KiB
Haskell
380 lines
18 KiB
Haskell
{-|
|
|
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 #-}
|
|
|
|
module PostgREST.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 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 Network.HTTP.Types.Header (RequestHeaders, hCookie)
|
|
import Network.HTTP.Types.URI (parseSimpleQuery)
|
|
import Network.Wai (Request (..))
|
|
import Network.Wai.Parse (parseHttpAccept)
|
|
import Web.Cookie (parseCookies)
|
|
|
|
import PostgREST.ApiRequest.QueryParams (QueryParams (..))
|
|
import PostgREST.ApiRequest.Types (ApiRequestError (..),
|
|
RangeError (..))
|
|
import PostgREST.Config (AppConfig (..),
|
|
OpenAPIMode (..))
|
|
import PostgREST.MediaType (MTPlanFormat (..),
|
|
MediaType (..))
|
|
import PostgREST.RangeQuery (NonnegRange, allRange,
|
|
convertToLimitZeroRange,
|
|
hasLimitZero,
|
|
rangeRequested)
|
|
import PostgREST.SchemaCache.Identifiers (FieldName,
|
|
QualifiedIdentifier (..),
|
|
Schema)
|
|
|
|
import qualified PostgREST.ApiRequest.Preferences as Preferences
|
|
import qualified PostgREST.ApiRequest.QueryParams as QueryParams
|
|
import qualified PostgREST.MediaType as MediaType
|
|
|
|
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
|
|
}
|
|
| ProcessedUrlEncoded { payArray :: [(Text, Text)], payKeys :: S.Set Text }
|
|
| 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 :: QualifiedIdentifier, tpIsRootSpec :: Bool}
|
|
| TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/"
|
|
|
|
{-|
|
|
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
|
|
, iPreferences :: Preferences.Preferences -- ^ Prefer header values
|
|
, 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
|
|
, 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
|
|
, iContentMediaType :: MediaType -- ^ The media type in the Content-Type header
|
|
}
|
|
|
|
-- | Examines HTTP request and translates it into user intent.
|
|
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 && 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
|
|
, iPreferences = Preferences.fromHeaders (configDbTxAllowOverride conf) hdrs
|
|
, 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
|
|
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 =
|
|
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
|
|
|
|
getMediaTypes :: AppConfig -> RequestHeaders -> Action -> PathInfo -> Either ApiRequestError (MediaType, MediaType)
|
|
getMediaTypes conf hdrs action path = do
|
|
acceptMediaType <- negotiateContent conf action path accepts
|
|
pure (acceptMediaType, contentMediaType)
|
|
where
|
|
accepts = maybe [MTAny] (map MediaType.decodeMediaType . parseHttpAccept) $ lookupHeader "accept"
|
|
contentMediaType = maybe MTApplicationJSON MediaType.decodeMediaType $ lookupHeader "content-type"
|
|
lookupHeader = flip lookup hdrs
|
|
|
|
getSchema :: AppConfig -> RequestHeaders -> ByteString -> Either ApiRequestError (Schema, Bool)
|
|
getSchema AppConfig{configDbSchemas} hdrs method = do
|
|
case profile of
|
|
Just p | p `notElem` configDbSchemas -> Left $ UnacceptableSchema $ toList configDbSchemas
|
|
| otherwise -> Right (p, True)
|
|
Nothing -> Right (defaultSchema, length configDbSchemas /= 1) -- if we have many schemas, assume the default schema was negotiated
|
|
where
|
|
defaultSchema = NonEmptyList.head configDbSchemas
|
|
profile = 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
|
|
contentProfile = T.decodeUtf8 <$> lookupHeader "Content-Profile"
|
|
acceptProfile = T.decodeUtf8 <$> lookupHeader "Accept-Profile"
|
|
lookupHeader = flip lookup hdrs
|
|
|
|
getRanges :: ByteString -> QueryParams -> RequestHeaders -> Either ApiRequestError (NonnegRange, HM.HashMap Text NonnegRange)
|
|
getRanges method QueryParams{qsOrder,qsRanges} hdrs
|
|
| isInvalidRange = Left $ InvalidRange (if rangeIsEmpty headerRange then LowerGTUpper else NegativeLimit)
|
|
| method `elem` ["PATCH", "DELETE"] && not (null qsRanges) && null qsOrder = Left LimitNoOrderError
|
|
| method == "PUT" && topLevelRange /= allRange = Left PutLimitNotAllowedError
|
|
| otherwise = Right (topLevelRange, ranges)
|
|
where
|
|
-- According to the RFC (https://www.rfc-editor.org/rfc/rfc9110.html#name-range),
|
|
-- the Range header must be ignored for all methods other than GET
|
|
headerRange = if method == "GET" then rangeRequested hdrs else allRange
|
|
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" (convertToLimitZeroRange limitRange headerAndLimitRange) qsRanges
|
|
-- The only emptyRange allowed is the limit zero range
|
|
isInvalidRange = topLevelRange == emptyRange && not (hasLimitZero limitRange)
|
|
topLevelRange = fromMaybe allRange $ HM.lookup "limit" ranges -- if no limit is specified, get all the request rows
|
|
|
|
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
|
|
|
|
shouldParsePayload = case (action, contentMediaType) of
|
|
(ActionMutate MutationCreate, _) -> True
|
|
(ActionInvoke InvPost, _) -> True
|
|
(ActionMutate MutationSingleUpsert, _) -> True
|
|
(ActionMutate MutationUpdate, _) -> True
|
|
_ -> False
|
|
|
|
columns = case action of
|
|
ActionMutate MutationCreate -> qsColumns
|
|
ActionMutate MutationUpdate -> qsColumns
|
|
ActionInvoke InvPost -> qsColumns
|
|
_ -> Nothing
|
|
|
|
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
|
|
|
|
|
|
-- | Do content negotiation. i.e. choose a media type based on the intersection of accepted/produced media types.
|
|
negotiateContent :: AppConfig -> Action -> PathInfo -> [MediaType] -> Either ApiRequestError MediaType
|
|
negotiateContent conf action path accepts =
|
|
case firstAcceptedPick of
|
|
Just MTAny -> Right MTApplicationJSON -- by default(for */*) we respond with json
|
|
Just mt -> Right mt
|
|
Nothing -> Left . MediaTypeError $ map MediaType.toMime accepts
|
|
where
|
|
-- if there are multiple accepted media types, pick the first
|
|
firstAcceptedPick = listToMaybe $ L.intersect accepts $ producedMediaTypes conf action path
|
|
|
|
producedMediaTypes :: AppConfig -> Action -> PathInfo -> [MediaType]
|
|
producedMediaTypes conf action path =
|
|
case action of
|
|
ActionRead _ -> defaultMediaTypes ++ rawMediaTypes
|
|
ActionInvoke _ -> invokeMediaTypes
|
|
ActionInfo -> defaultMediaTypes
|
|
ActionMutate _ -> defaultMediaTypes
|
|
ActionInspect _ -> inspectMediaTypes
|
|
where
|
|
inspectMediaTypes = [MTOpenAPI, MTApplicationJSON, MTArrayJSONStrip, MTAny]
|
|
invokeMediaTypes =
|
|
defaultMediaTypes
|
|
++ rawMediaTypes
|
|
++ [MTOpenAPI | pathIsRootSpec path]
|
|
defaultMediaTypes =
|
|
[MTApplicationJSON, MTArrayJSONStrip, MTSingularJSON True, MTSingularJSON False, MTGeoJSON, MTTextCSV] ++
|
|
[MTPlan MTApplicationJSON PlanText mempty | configDbPlanEnabled conf] ++ [MTAny]
|
|
rawMediaTypes = configRawMediaTypes conf `union` [MTOctetStream, MTTextPlain, MTTextXML]
|