diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 0e369d168..20a5bdb0e 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -89,7 +89,6 @@ data RequestContext = RequestContext { ctxConfig :: AppConfig , ctxDbStructure :: DbStructure , ctxApiRequest :: ApiRequest - , ctxContentType :: ContentType } type Handler = ExceptT Error @@ -161,7 +160,7 @@ postgrestResponse -> UTCTime -> Wai.Request -> Handler IO Wai.Response -postgrestResponse conf@AppConfig{..} maybeDbStructure pool time req = do +postgrestResponse conf maybeDbStructure pool time req = do body <- lift $ Wai.strictRequestBody req dbStructure <- @@ -173,21 +172,14 @@ postgrestResponse conf@AppConfig{..} maybeDbStructure pool time req = do apiRequest@ApiRequest{..} <- liftEither . mapLeft Error.ApiRequestError $ - ApiRequest.userApiRequest configDbSchemas configDbRootSpec dbStructure req body + ApiRequest.userApiRequest conf dbStructure req body -- The JWT must be checked before touching the db jwtClaims <- Auth.jwtClaims conf (toS iJWT) time - contentType <- - case ApiRequest.mutuallyAgreeable (requestContentTypes conf apiRequest) iAccepts of - Just ct -> - return ct - Nothing -> - throwError . Error.ContentTypeError $ map ContentType.toMime iAccepts - let handleReq apiReq = - handleRequest $ RequestContext conf dbStructure apiReq contentType + handleRequest $ RequestContext conf dbStructure apiReq runDbHandler pool (txMode apiRequest) jwtClaims . Middleware.optionalRollback conf apiRequest $ @@ -205,7 +197,7 @@ runDbHandler pool mode jwtClaims handler = do liftEither resp handleRequest :: RequestContext -> DbHandler Wai.Response -handleRequest context@(RequestContext _ _ ApiRequest{..} _) = +handleRequest context@(RequestContext _ _ ApiRequest{..}) = case (iAction, iTarget) of (ActionRead headersOnly, TargetIdent identifier) -> handleRead headersOnly identifier context @@ -246,9 +238,9 @@ handleRead headersOnly identifier context@RequestContext{..} = do else countQuery ) - (ctxContentType == CTSingularJSON) + (iAcceptContentType == CTSingularJSON) (shouldCount iPreferCount) - (ctxContentType == CTTextCSV) + (iAcceptContentType == CTTextCSV) bField (pgVersion ctxDbStructure) configDbPreparedStatements @@ -268,7 +260,7 @@ handleRead headersOnly identifier context@RequestContext{..} = do ] ++ contentTypeHeaders context - failNotSingular ctxContentType queryTotal . response status headers $ + failNotSingular iAcceptContentType queryTotal . response status headers $ if headersOnly then mempty else toS body readTotal :: AppConfig -> ApiRequest -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64) @@ -317,14 +309,14 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do (\x -> ("Preference-Applied", BS8.pack $ show x)) <$> iPreferResolution ] - failNotSingular ctxContentType resQueryTotal $ + failNotSingular iAcceptContentType resQueryTotal $ if iPreferRepresentation == Full then response HTTP.status201 (headers ++ contentTypeHeaders context) (toS resBody) else response HTTP.status201 headers mempty handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response -handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} contentType) = do +handleUpdate identifier context@(RequestContext _ _ ApiRequest{..}) = do WriteQueryResult{..} <- writeQuery identifier False mempty context let @@ -339,14 +331,14 @@ handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} contentType) RangeQuery.contentRangeH 0 (resQueryTotal - 1) $ if shouldCount iPreferCount then Just resQueryTotal else Nothing - failNotSingular contentType resQueryTotal $ + failNotSingular iAcceptContentType resQueryTotal $ if fullRepr then response status (contentTypeHeaders context ++ [contentRangeHeader]) (toS resBody) else response status [contentRangeHeader] mempty handleSingleUpsert :: QualifiedIdentifier -> RequestContext-> DbHandler Wai.Response -handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do +handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..}) = do when (iTopLevelRange /= RangeQuery.allRange) $ throwError Error.PutRangeNotAllowedError @@ -370,7 +362,7 @@ handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do response HTTP.status204 (contentTypeHeaders context) mempty handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response -handleDelete identifier context@(RequestContext _ _ ApiRequest{..} contentType) = do +handleDelete identifier context@(RequestContext _ _ ApiRequest{..}) = do WriteQueryResult{..} <- writeQuery identifier False mempty context let @@ -379,7 +371,7 @@ handleDelete identifier context@(RequestContext _ _ ApiRequest{..} contentType) RangeQuery.contentRangeH 1 0 $ if shouldCount iPreferCount then Just resQueryTotal else Nothing - failNotSingular contentType resQueryTotal $ + failNotSingular iAcceptContentType resQueryTotal $ if iPreferRepresentation == Full then response HTTP.status200 (contentTypeHeaders context ++ [contentRangeHeader]) @@ -443,8 +435,8 @@ handleInvoke invMethod proc context@RequestContext{..} = do (QueryBuilder.readRequestToQuery req) (QueryBuilder.readRequestToCountQuery req) (shouldCount iPreferCount) - (ctxContentType == CTSingularJSON) - (ctxContentType == CTTextCSV) + (iAcceptContentType == CTSingularJSON) + (iAcceptContentType == CTTextCSV) (iPreferParameters == Just MultipleObjects) bField (pgVersion ctxDbStructure) @@ -456,13 +448,13 @@ handleInvoke invMethod proc context@RequestContext{..} = do (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange queryTotal tableTotal - failNotSingular ctxContentType queryTotal $ + failNotSingular iAcceptContentType queryTotal $ response status (contentTypeHeaders context ++ [contentRange]) (if invMethod == InvHead then mempty else toS body) handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response -handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest _) = do +handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest) = do body <- lift $ OpenAPI.encode conf dbStructure @@ -519,9 +511,9 @@ writeQuery identifier@QualifiedIdentifier{..} isInsert pkCols context@RequestCon Statements.createWriteStatement (QueryBuilder.readRequestToQuery readReq) (QueryBuilder.mutateRequestToQuery mutateReq) - (ctxContentType == CTSingularJSON) + (iAcceptContentType ctxApiRequest == CTSingularJSON) isInsert - (ctxContentType == CTTextCSV) + (iAcceptContentType ctxApiRequest == CTTextCSV) (iPreferRepresentation ctxApiRequest) pkCols (pgVersion ctxDbStructure) @@ -562,7 +554,7 @@ returnsScalar (TargetProc proc _) = Proc.procReturnsScalar proc returnsScalar _ = False readRequest :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m ReadRequest -readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure apiRequest _) = +readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure apiRequest) = liftEither $ ReqBuilder.readRequest qiSchema qiName configDbMaxRows (dbRelationships dbStructure) @@ -570,32 +562,16 @@ readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure ap contentTypeHeaders :: RequestContext -> [HTTP.Header] contentTypeHeaders RequestContext{..} = - ContentType.toHeader ctxContentType : maybeToList (profileHeader ctxApiRequest) + ContentType.toHeader (iAcceptContentType ctxApiRequest) : maybeToList (profileHeader ctxApiRequest) -requestContentTypes :: AppConfig -> ApiRequest -> [ContentType] -requestContentTypes conf ApiRequest{..} = - case iAction of - ActionRead _ -> defaultContentTypes ++ rawContentTypes conf - ActionInvoke _ -> invokeContentTypes - ActionInspect _ -> [CTOpenAPI, CTApplicationJSON] - ActionInfo -> [CTTextCSV] - _ -> defaultContentTypes - where - invokeContentTypes = - defaultContentTypes - ++ rawContentTypes conf - ++ [CTOpenAPI | ApiRequest.tpIsRootSpec iTarget] - defaultContentTypes = - [CTApplicationJSON, CTSingularJSON, CTTextCSV] - --- | --- If raw(binary) output is requested, check that ContentType is one of the admitted --- rawContentTypes and that`?select=...` contains only one field other than `*` +-- | If raw(binary) output is requested, check that ContentType is one of the +-- admitted rawContentTypes and that`?select=...` contains only one field other +-- than `*` binaryField :: Monad m => RequestContext -> ReadRequest -> Handler m (Maybe FieldName) binaryField RequestContext{..} readReq - | returnsScalar (iTarget ctxApiRequest) && ctxContentType `elem` rawContentTypes ctxConfig = + | returnsScalar (iTarget ctxApiRequest) && iAcceptContentType ctxApiRequest `elem` rawContentTypes ctxConfig = return $ Just "pgrst_scalar" - | ctxContentType `elem` rawContentTypes ctxConfig = + | iAcceptContentType ctxApiRequest `elem` rawContentTypes ctxConfig = let fldNames = fstFieldNames readReq fieldName = headMay fldNames @@ -603,7 +579,7 @@ binaryField RequestContext{..} readReq if length fldNames == 1 && fieldName /= Just "*" then return fieldName else - throwError $ Error.BinaryFieldError ctxContentType + throwError $ Error.BinaryFieldError (iAcceptContentType ctxApiRequest) | otherwise = return Nothing diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 157f5d67e..2712e269c 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -59,6 +59,7 @@ data ApiRequestError | AmbiguousRelBetween Text Text [Relationship] | InvalidFilters | UnacceptableSchema [Text] + | ContentTypeError [ByteString] | UnsupportedVerb -- Unreachable? instance PgrstError ApiRequestError where @@ -71,6 +72,7 @@ instance PgrstError ApiRequestError where status (NoRelBetween _ _) = HT.status400 status AmbiguousRelBetween{} = HT.status300 status (UnacceptableSchema _) = HT.status406 + status (ContentTypeError _) = HT.status415 headers _ = [ContentType.toHeader CTApplicationJSON] @@ -95,6 +97,8 @@ instance JSON.ToJSON ApiRequestError where "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)] toJSON (UnacceptableSchema schemas) = JSON.object [ "message" .= ("The schema must be one of the following: " <> T.intercalate ", " schemas)] + toJSON (ContentTypeError cts) = JSON.object [ + "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)] compressedRel :: Relationship -> JSON.Value compressedRel Relationship{..} = @@ -237,7 +241,6 @@ data Error | JwtTokenMissing | JwtTokenInvalid Text | SingularityError Integer - | ContentTypeError [ByteString] | NotFound | ApiRequestError ApiRequestError | PgErr PgError @@ -252,7 +255,6 @@ instance PgrstError Error where status JwtTokenMissing = HT.status500 status (JwtTokenInvalid _) = HT.unauthorized401 status (SingularityError _) = HT.status406 - status (ContentTypeError _) = HT.status415 status NotFound = HT.status404 status (PgErr err) = status err status (ApiRequestError err) = status err @@ -278,8 +280,6 @@ instance JSON.ToJSON Error where toJSON PutMatchingPkError = JSON.object [ "message" .= ("Payload values do not match URL in primary key column(s)" :: Text)] - toJSON (ContentTypeError cts) = JSON.object [ - "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)] toJSON (SingularityError n) = JSON.object [ "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text), "details" .= T.unwords ["Results contain", show n, "rows,", toS (ContentType.toMime CTSingularJSON), "requires 1 row"]] diff --git a/src/PostgREST/Request/ApiRequest.hs b/src/PostgREST/Request/ApiRequest.hs index 141242030..7fcbf60b9 100644 --- a/src/PostgREST/Request/ApiRequest.hs +++ b/src/PostgREST/Request/ApiRequest.hs @@ -2,9 +2,10 @@ Module : PostgREST.Request.ApiRequest Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. -} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} module PostgREST.Request.ApiRequest ( ApiRequest(..) @@ -13,7 +14,6 @@ module PostgREST.Request.ApiRequest , Action(..) , Target(..) , PayloadJSON(..) - , mutuallyAgreeable , userApiRequest ) where @@ -30,7 +30,7 @@ import qualified Data.Vector as V import Control.Arrow ((***)) import Data.Aeson.Types (emptyArray, emptyObject) -import Data.List (last, lookup, partition) +import Data.List (last, lookup, partition, union) import Data.List.NonEmpty (head) import Data.Maybe (fromJust) import Data.Ranged.Boundaries (Boundary (..)) @@ -44,6 +44,7 @@ import Network.Wai (Request (..)) import Network.Wai.Parse (parseHttpAccept) import Web.Cookie (parseCookiesText) +import PostgREST.Config (AppConfig (..)) import PostgREST.ContentType (ContentType (..)) import PostgREST.DbStructure (DbStructure (..)) import PostgREST.DbStructure.Identifiers (FieldName, @@ -137,7 +138,6 @@ data ApiRequest = ApiRequest { , iRange :: M.HashMap ByteString 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 - , iAccepts :: [ContentType] -- ^ Content types the client will accept, [CTAny] if no Accept header , iPayload :: Maybe PayloadJSON -- ^ 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 @@ -158,22 +158,24 @@ data ApiRequest = ApiRequest { , 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. + , iAcceptContentType :: ContentType } -- | Examines HTTP request and translates it into user intent. -userApiRequest :: NonEmpty Schema -> Maybe Text -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest -userApiRequest confSchemas rootSpec dbStructure req reqBody - | isJust profile && fromJust profile `notElem` confSchemas = Left $ UnacceptableSchema $ toList confSchemas +userApiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest +userApiRequest conf@AppConfig{..} dbStructure req reqBody + | 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 . toS) witness payload | isLeft parsedColumns = either Left witness parsedColumns - | otherwise = Right ApiRequest { + | otherwise = do + acceptContentType <- findAcceptContentType conf action target accepts + return ApiRequest { iAction = action , iTarget = target , iRange = ranges , iTopLevelRange = topLevelRange - , iAccepts = maybe [CTAny] (map ContentType.decodeContentType . parseHttpAccept) $ lookupHeader "accept" , iPayload = relevantPayload , iPreferRepresentation = representation , iPreferParameters = if | hasPrefer (show SingleObject) -> Just SingleObject @@ -206,8 +208,10 @@ userApiRequest confSchemas rootSpec dbStructure req reqBody , iMethod = method , iProfile = profile , iSchema = schema + , iAcceptContentType = acceptContentType } 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..) @@ -287,9 +291,9 @@ userApiRequest confSchemas rootSpec dbStructure req reqBody "OPTIONS" -> ActionInfo _ -> ActionInspect{isHead=False} - defaultSchema = head confSchemas + defaultSchema = head configDbSchemas profile - | length confSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config + | length configDbSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config = Nothing | otherwise = case action of -- POST/PATCH/PUT/DELETE don't use the same header as per the spec @@ -308,7 +312,7 @@ userApiRequest confSchemas rootSpec dbStructure req reqBody callFindProc proc = findProc (QualifiedIdentifier schema proc) payloadColumns (hasPrefer (show SingleObject)) $ dbProcs dbStructure in case path of - [] -> case rootSpec of + [] -> case configDbRootSpec of Just pName -> TargetProc (callFindProc pName) True Nothing -> TargetDefaultSpec schema [table] -> TargetIdent $ QualifiedIdentifier schema table @@ -423,3 +427,31 @@ payloadAttributes raw json = _ -> Just emptyPJArray where emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty + +findAcceptContentType :: AppConfig -> Action -> Target -> [ContentType] -> Either ApiRequestError ContentType +findAcceptContentType conf action target accepts = + case mutuallyAgreeable (requestContentTypes conf action target) accepts of + Just ct -> + Right ct + Nothing -> + Left . ContentTypeError $ map ContentType.toMime accepts + +requestContentTypes :: AppConfig -> Action -> Target -> [ContentType] +requestContentTypes conf action target = + case action of + ActionRead _ -> defaultContentTypes ++ rawContentTypes conf + ActionInvoke _ -> invokeContentTypes + ActionInspect _ -> [CTOpenAPI, CTApplicationJSON] + ActionInfo -> [CTTextCSV] + _ -> defaultContentTypes + where + invokeContentTypes = + defaultContentTypes + ++ rawContentTypes conf + ++ [CTOpenAPI | tpIsRootSpec target] + defaultContentTypes = + [CTApplicationJSON, CTSingularJSON, CTTextCSV] + +rawContentTypes :: AppConfig -> [ContentType] +rawContentTypes AppConfig{..} = + (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]