191 lines
10 KiB
Haskell
191 lines
10 KiB
Haskell
{-|
|
|
Module : PostgREST.Request.ApiRequest
|
|
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
|
|
-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module PostgREST.ApiRequest
|
|
( ApiRequest(..)
|
|
, userApiRequest
|
|
, userPreferences
|
|
) where
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.HashMap.Strict as HM
|
|
import qualified Data.List.NonEmpty as NonEmptyList
|
|
import qualified Data.Set as S
|
|
import qualified Data.Text.Encoding as T
|
|
|
|
import Data.List (lookup)
|
|
import Data.Ranged.Ranges (emptyRange, rangeIntersection,
|
|
rangeIsEmpty)
|
|
import Network.HTTP.Types.Header (RequestHeaders, hCookie)
|
|
import Network.Wai (Request (..))
|
|
import Network.Wai.Parse (parseHttpAccept)
|
|
import Web.Cookie (parseCookies)
|
|
|
|
import PostgREST.ApiRequest.Payload (getPayload)
|
|
import PostgREST.ApiRequest.QueryParams (QueryParams (..))
|
|
import PostgREST.ApiRequest.Types (Action (..), DbAction (..),
|
|
InvokeMethod (..),
|
|
Mutation (..), Payload (..),
|
|
RequestBody, Resource (..))
|
|
import PostgREST.Config (AppConfig (..),
|
|
OpenAPIMode (..))
|
|
import PostgREST.Config.Database (TimezoneNames)
|
|
import PostgREST.Error (ApiRequestError (..),
|
|
RangeError (..))
|
|
import PostgREST.MediaType (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
|
|
|
|
{-|
|
|
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 -- ^ Action on the resource
|
|
, iRange :: HM.HashMap Text NonnegRange -- ^ Requested range of rows within response
|
|
, iTopLevelRange :: NonnegRange -- ^ Requested range of rows from the top level
|
|
, 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 resolved media types in the Accept, considering quality(q) factors
|
|
, iContentMediaType :: MediaType -- ^ The media type in the Content-Type header
|
|
}
|
|
|
|
-- | Examines HTTP request and translates it into user intent.
|
|
userApiRequest :: AppConfig -> Preferences.Preferences -> Request -> RequestBody -> Either ApiRequestError ApiRequest
|
|
userApiRequest conf prefs req reqBody = do
|
|
resource <- getResource conf $ pathInfo req
|
|
(schema, negotiatedByProfile) <- getSchema conf hdrs method
|
|
act <- getAction resource schema method
|
|
qPrms <- first QueryParamError $ QueryParams.parse (actIsInvokeSafe act) $ rawQueryString req
|
|
(topLevelRange, ranges) <- getRanges method qPrms hdrs
|
|
(payload, columns) <- getPayload reqBody contentMediaType qPrms act
|
|
return $ ApiRequest {
|
|
iAction = act
|
|
, iRange = ranges
|
|
, iTopLevelRange = topLevelRange
|
|
, iPayload = payload
|
|
, iPreferences = prefs
|
|
, iQueryParams = qPrms
|
|
, iColumns = columns
|
|
, iHeaders = iHdrs
|
|
, iCookies = iCkies
|
|
, iPath = rawPathInfo req
|
|
, iMethod = method
|
|
, iSchema = schema
|
|
, iNegotiatedByProfile = negotiatedByProfile
|
|
, iAcceptMediaType = maybe [MTAny] (map MediaType.decodeMediaType . parseHttpAccept) $ lookupHeader "accept"
|
|
, 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"
|
|
contentMediaType = maybe MTApplicationJSON MediaType.decodeMediaType $ lookupHeader "content-type"
|
|
actIsInvokeSafe x = case x of {ActDb (ActRoutine _ (InvRead _)) -> True; _ -> False}
|
|
|
|
-- | Parses the Prefer header
|
|
userPreferences :: AppConfig -> Request -> TimezoneNames -> Preferences.Preferences
|
|
userPreferences conf req timezones = Preferences.fromHeaders (configDbTxAllowOverride conf) timezones $ requestHeaders req
|
|
|
|
getResource :: AppConfig -> [Text] -> Either ApiRequestError Resource
|
|
getResource AppConfig{configOpenApiMode, configDbRootSpec} = \case
|
|
[] ->
|
|
case (configOpenApiMode,configDbRootSpec) of
|
|
(OADisabled,_) -> Left OpenAPIDisabled
|
|
(_, Just qi) -> Right $ ResourceRoutine (qiName qi)
|
|
(_, Nothing) -> Right ResourceSchema
|
|
|
|
[table] -> Right $ ResourceRelation table
|
|
["rpc", pName] -> Right $ ResourceRoutine pName
|
|
_ -> Left InvalidResourcePath
|
|
|
|
getAction :: Resource -> Schema -> ByteString -> Either ApiRequestError Action
|
|
getAction resource schema method =
|
|
case (resource, method) of
|
|
(ResourceRoutine rout, "HEAD") -> Right . ActDb $ ActRoutine (qi rout) $ InvRead True
|
|
(ResourceRoutine rout, "GET") -> Right . ActDb $ ActRoutine (qi rout) $ InvRead False
|
|
(ResourceRoutine rout, "POST") -> Right . ActDb $ ActRoutine (qi rout) Inv
|
|
(ResourceRoutine rout, "OPTIONS") -> Right $ ActRoutineInfo (qi rout) $ InvRead True
|
|
(ResourceRoutine _, _) -> Left $ InvalidRpcMethod method
|
|
|
|
(ResourceRelation rel, "HEAD") -> Right . ActDb $ ActRelationRead (qi rel) True
|
|
(ResourceRelation rel, "GET") -> Right . ActDb $ ActRelationRead (qi rel) False
|
|
(ResourceRelation rel, "POST") -> Right . ActDb $ ActRelationMut (qi rel) MutationCreate
|
|
(ResourceRelation rel, "PUT") -> Right . ActDb $ ActRelationMut (qi rel) MutationSingleUpsert
|
|
(ResourceRelation rel, "PATCH") -> Right . ActDb $ ActRelationMut (qi rel) MutationUpdate
|
|
(ResourceRelation rel, "DELETE") -> Right . ActDb $ ActRelationMut (qi rel) MutationDelete
|
|
(ResourceRelation rel, "OPTIONS") -> Right $ ActRelationInfo (qi rel)
|
|
|
|
(ResourceSchema, "HEAD") -> Right . ActDb $ ActSchemaRead schema True
|
|
(ResourceSchema, "GET") -> Right . ActDb $ ActSchemaRead schema False
|
|
(ResourceSchema, "OPTIONS") -> Right ActSchemaInfo
|
|
|
|
_ -> Left $ UnsupportedMethod method
|
|
where
|
|
qi = QualifiedIdentifier schema
|
|
|
|
|
|
getSchema :: AppConfig -> RequestHeaders -> ByteString -> Either ApiRequestError (Schema, Bool)
|
|
getSchema AppConfig{configDbSchemas} hdrs method = do
|
|
case profile of
|
|
Just p | p `notElem` configDbSchemas -> Left $ UnacceptableSchema p $ 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{qsRanges} hdrs
|
|
| isInvalidRange = Left $ InvalidRange (if rangeIsEmpty headerRange then LowerGTUpper else NegativeLimit)
|
|
| 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
|