refactor: Move accept content type code from App into ApiRequest (#1830)

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)
+        (iAcceptContentType == CTSingularJSON)
-        (ctxContentType == CTTextCSV)
+        (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]
+-- | If raw(binary) output is requested, check that ContentType is one of the
-requestContentTypes conf ApiRequest{..} =
+-- admitted rawContentTypes and that`?select=...` contains only one field other
-  case iAction of
+-- than `*`
-    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 `*`
 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
 

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"]]

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 LambdaCase      #-}
-{-# LANGUAGE MultiWayIf     #-}
+{-# LANGUAGE MultiWayIf      #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# 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 :: AppConfig -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest
-userApiRequest confSchemas rootSpec dbStructure req reqBody
+userApiRequest conf@AppConfig{..} dbStructure req reqBody
-  | isJust profile && fromJust profile `notElem` confSchemas = Left $ UnacceptableSchema $ toList confSchemas
+  | 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]