refactor: move media type logic to Plan module

src/PostgREST/ApiRequest.hs

@@ -15,6 +15,7 @@ module PostgREST.ApiRequest
   , Action(..)
   , Target(..)
   , Payload(..)
+  , PathInfo(..)
   , userApiRequest
   ) where
 
@@ -26,7 +27,6 @@ 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
@@ -37,7 +37,7 @@ import Data.Either.Combinators (mapBoth)
 
 import Control.Arrow             ((***))
 import Data.Aeson.Types          (emptyArray, emptyObject)
-import Data.List                 (lookup, union)
+import Data.List                 (lookup)
 import Data.Ranged.Ranges        (emptyRange, rangeIntersection,
                                   rangeIsEmpty)
 import Network.HTTP.Types.Header (RequestHeaders, hCookie)
@@ -51,8 +51,7 @@ import PostgREST.ApiRequest.Types        (ApiRequestError (..),
                                           RangeError (..))
 import PostgREST.Config                  (AppConfig (..),
                                           OpenAPIMode (..))
-import PostgREST.MediaType               (MTPlanFormat (..),
-                                          MediaType (..))
+import PostgREST.MediaType               (MediaType (..))
 import PostgREST.RangeQuery              (NonnegRange, allRange,
                                           convertToLimitZeroRange,
                                           hasLimitZero,
@@ -128,10 +127,11 @@ data ApiRequest = ApiRequest {
   , iHeaders             :: [(ByteString, ByteString)]       -- ^ HTTP request headers
   , iCookies             :: [(ByteString, ByteString)]       -- ^ Request Cookies
   , iPath                :: ByteString                       -- ^ Raw request path
+  , iPathInfo            :: PathInfo                         -- ^ Cached info about the 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
+  , iAcceptMediaType     :: [MediaType]                      -- ^ The resolved media types in the Accept, considering quality(q) factors
   , iContentMediaType    :: MediaType                        -- ^ The media type in the Content-Type header
   }
 
@@ -141,7 +141,6 @@ 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
@@ -159,10 +158,11 @@ userApiRequest conf req reqBody = do
   , iHeaders = iHdrs
   , iCookies = iCkies
   , iPath = rawPathInfo req
+  , iPathInfo = pInfo
   , iMethod = method
   , iSchema = schema
   , iNegotiatedByProfile = negotiatedByProfile
-  , iAcceptMediaType = acceptMediaType
+  , iAcceptMediaType = maybe [MTAny] (map MediaType.decodeMediaType . parseHttpAccept) $ lookupHeader "accept"
   , iContentMediaType = contentMediaType
   }
   where
@@ -171,6 +171,7 @@ userApiRequest conf req reqBody = do
     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"
 
 getPathInfo :: AppConfig -> [Text] -> Either ApiRequestError PathInfo
 getPathInfo AppConfig{configOpenApiMode, configDbRootSpec} path =
@@ -204,15 +205,6 @@ getAction PathInfo{pathIsProc, pathIsDefSpec} method =
       "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
@@ -346,34 +338,3 @@ payloadAttributes raw json =
     _ -> 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]

src/PostgREST/App.hs

@@ -171,7 +171,7 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
     (ActionRead headersOnly, TargetIdent identifier) -> do
       wrPlan <- liftEither $ Plan.wrappedReadPlan identifier conf sCache apiReq
       resultSet <- runQuery roleIsoLvl (Plan.wrTxMode wrPlan) $ Query.readQuery wrPlan conf apiReq
-      return $ Response.readResponse headersOnly identifier apiReq resultSet
+      return $ Response.readResponse wrPlan headersOnly identifier apiReq resultSet
 
     (ActionMutate MutationCreate, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationCreate apiReq identifier conf sCache
@@ -181,25 +181,26 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
     (ActionMutate MutationUpdate, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationUpdate apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.updateQuery mrPlan apiReq conf
-      return $ Response.updateResponse apiReq resultSet
+      return $ Response.updateResponse mrPlan apiReq resultSet
 
     (ActionMutate MutationSingleUpsert, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationSingleUpsert apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.singleUpsertQuery mrPlan apiReq conf
-      return $ Response.singleUpsertResponse apiReq resultSet
+      return $ Response.singleUpsertResponse mrPlan apiReq resultSet
 
     (ActionMutate MutationDelete, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationDelete apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.deleteQuery mrPlan apiReq conf
-      return $ Response.deleteResponse apiReq resultSet
+      return $ Response.deleteResponse mrPlan apiReq resultSet
 
     (ActionInvoke invMethod, TargetProc identifier _) -> do
       cPlan <- liftEither $ Plan.callReadPlan identifier conf sCache apiReq invMethod
       resultSet <- runQuery (fromMaybe roleIsoLvl $ pdIsoLvl (Plan.crProc cPlan))(Plan.crTxMode cPlan) $ Query.invokeQuery (Plan.crProc cPlan) cPlan apiReq conf pgVer
-      return $ Response.invokeResponse invMethod (Plan.crProc cPlan) apiReq resultSet
+      return $ Response.invokeResponse cPlan invMethod (Plan.crProc cPlan) apiReq resultSet
 
     (ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
-      oaiResult <- runQuery roleIsoLvl Plan.inspectPlanTxMode $ Query.openApiQuery sCache pgVer conf tSchema
+      iPlan <- liftEither $ Plan.inspectPlan conf apiReq
+      oaiResult <- runQuery roleIsoLvl (Plan.ipTxmode iPlan) $ Query.openApiQuery sCache pgVer conf tSchema
       return $ Response.openApiResponse (T.decodeUtf8 prettyVersion, docsVersion) headersOnly oaiResult conf sCache iSchema iNegotiatedByProfile
 
     (ActionInfo, TargetIdent identifier) ->

src/PostgREST/Plan.hs

@@ -19,10 +19,11 @@ module PostgREST.Plan
   ( wrappedReadPlan
   , mutateReadPlan
   , callReadPlan
+  , inspectPlan
   , WrappedReadPlan(..)
   , MutateReadPlan(..)
   , CallReadPlan(..)
-  , inspectPlanTxMode
+  , InspectPlan(..)
   ) where
 
 import qualified Data.ByteString.Lazy          as LBS
@@ -40,10 +41,12 @@ import PostgREST.ApiRequest                  (Action (..),
                                               ApiRequest (..),
                                               InvokeMethod (..),
                                               Mutation (..),
+                                              PathInfo (..),
                                               Payload (..))
 import PostgREST.Config                      (AppConfig (..))
 import PostgREST.Error                       (Error (..))
-import PostgREST.MediaType                   (MediaType (..))
+import PostgREST.MediaType                   (MTPlanFormat (..),
+                                              MediaType (..))
 import PostgREST.Query.SqlFragment           (sourceCTEName)
 import PostgREST.RangeQuery                  (NonnegRange, allRange,
                                               convertToLimitZeroRange,
@@ -80,6 +83,7 @@ import PostgREST.Plan.Types
 
 import qualified Hasql.Transaction.Sessions       as SQL
 import qualified PostgREST.ApiRequest.QueryParams as QueryParams
+import qualified PostgREST.MediaType              as MediaType
 
 import Protolude hiding (from)
 
@@ -91,13 +95,15 @@ data WrappedReadPlan = WrappedReadPlan {
   wrReadPlan :: ReadPlanTree
 , wrTxMode   :: SQL.Mode
 , wrResAgg   :: ResultAggregate
+, wrMedia    :: MediaType
 }
 
 data MutateReadPlan = MutateReadPlan {
   mrReadPlan   :: ReadPlanTree
 , mrMutatePlan :: MutatePlan
 , mrTxMode     :: SQL.Mode
 , mrResAgg     :: ResultAggregate
+, mrMedia      :: MediaType
 }
 
 data CallReadPlan = CallReadPlan {
@@ -106,20 +112,28 @@ data CallReadPlan = CallReadPlan {
 , crTxMode   :: SQL.Mode
 , crProc     :: Routine
 , crResAgg   :: ResultAggregate
+, crMedia    :: MediaType
+}
+
+data InspectPlan = InspectPlan {
+  ipMedia  :: MediaType
+, ipTxmode :: SQL.Mode
 }
 
 wrappedReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> Either Error WrappedReadPlan
 wrappedReadPlan  identifier conf sCache apiRequest = do
   rPlan <- readPlan identifier conf sCache apiRequest
-  binField <- mapLeft ApiRequestError $ binaryField conf (iAcceptMediaType apiRequest) Nothing rPlan
-  return $ WrappedReadPlan rPlan SQL.Read $ mediaToAggregate (iAcceptMediaType apiRequest) binField apiRequest
+  mediaType <- mapLeft ApiRequestError $ negotiateContent conf (iAction apiRequest) (iPathInfo apiRequest) (iAcceptMediaType apiRequest)
+  binField <- mapLeft ApiRequestError $ binaryField conf mediaType Nothing rPlan
+  return $ WrappedReadPlan rPlan SQL.Read (mediaToAggregate mediaType binField apiRequest) mediaType
 
 mutateReadPlan :: Mutation -> ApiRequest -> QualifiedIdentifier -> AppConfig -> SchemaCache -> Either Error MutateReadPlan
 mutateReadPlan  mutation apiRequest identifier conf sCache = do
   rPlan <- readPlan identifier conf sCache apiRequest
-  binField <- mapLeft ApiRequestError $ binaryField conf (iAcceptMediaType apiRequest) Nothing rPlan
   mPlan <- mutatePlan mutation identifier apiRequest sCache rPlan
-  return $ MutateReadPlan rPlan mPlan SQL.Write $ mediaToAggregate (iAcceptMediaType apiRequest) binField apiRequest
+  mediaType <- mapLeft ApiRequestError $ negotiateContent conf (iAction apiRequest) (iPathInfo apiRequest) (iAcceptMediaType apiRequest)
+  binField <- mapLeft ApiRequestError $ binaryField conf mediaType Nothing rPlan
+  return $ MutateReadPlan rPlan mPlan SQL.Write (mediaToAggregate mediaType binField apiRequest) mediaType
 
 callReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> InvokeMethod -> Either Error CallReadPlan
 callReadPlan identifier conf sCache apiRequest invMethod = do
@@ -143,12 +157,18 @@ callReadPlan identifier conf sCache apiRequest invMethod = do
           (InvPost, Routine.Immutable) -> SQL.Read
           (InvPost, Routine.Volatile)  -> SQL.Write
       cPlan = callPlan proc apiRequest paramKeys args rPlan
-  binField <- mapLeft ApiRequestError $ binaryField conf (iAcceptMediaType apiRequest) (Just proc) rPlan
-  return $ CallReadPlan rPlan cPlan txMode proc $ mediaToAggregate (iAcceptMediaType apiRequest) binField apiRequest
+  mediaType <- mapLeft ApiRequestError $ negotiateContent conf (iAction apiRequest) (iPathInfo apiRequest) (iAcceptMediaType apiRequest)
+  binField <- mapLeft ApiRequestError $ binaryField conf mediaType (Just proc) rPlan
+  return $ CallReadPlan rPlan cPlan txMode proc (mediaToAggregate mediaType binField apiRequest) mediaType
   where
     Preferences{..} = iPreferences apiRequest
     qsParams' = QueryParams.qsParams (iQueryParams apiRequest)
 
+inspectPlan :: AppConfig -> ApiRequest -> Either Error InspectPlan
+inspectPlan conf apiRequest = do
+  mediaType <- mapLeft ApiRequestError $ negotiateContent conf (iAction apiRequest) (iPathInfo apiRequest) (iAcceptMediaType apiRequest)
+  return $ InspectPlan mediaType SQL.Read
+
 {-|
   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.
@@ -206,9 +226,6 @@ findProc qi argumentsKeys paramsAsSingleObject allProcs contentMediaType isInvPo
       -- and can match any or none of the default parameters.
         (reqParams, optParams) -> argumentsKeys `S.difference` S.fromList (ppName <$> optParams) == S.fromList (ppName <$> reqParams)
 
-inspectPlanTxMode :: SQL.Mode
-inspectPlanTxMode = SQL.Read
-
 -- | During planning we need to resolve Field -> CoercibleField (finding the context specific target type and map function).
 -- | ResolverContext facilitates this without the need to pass around a laundry list of parameters.
 data ResolverContext = ResolverContext
@@ -873,3 +890,33 @@ mediaToAggregate mt binField apiReq@ApiRequest{iAction=act, iPreferences=Prefere
       ActionRead _isHead     -> _isHead -- no need for an aggregate on HEAD https://github.com/PostgREST/postgrest/issues/2849
       ActionInvoke invMethod -> invMethod == InvHead
       _                      -> False
+
+-- | 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 `L.union` [MTOctetStream, MTTextPlain, MTTextXML]