feat: custom media types for Accept

* test text/html and drop HtmlRawOutputSpec.hs
* all tests passing, removed all pendingWith

postgrest.cabal

@@ -208,7 +208,6 @@ test-suite spec
                       Feature.Query.EmbedDisambiguationSpec
                       Feature.Query.EmbedInnerJoinSpec
                       Feature.Query.ErrorSpec
-                      Feature.Query.HtmlRawOutputSpec
                       Feature.Query.InsertSpec
                       Feature.Query.JsonOperatorSpec
                       Feature.Query.MultipleSchemaSpec

src/PostgREST/App.hs

@@ -220,7 +220,7 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
       return $ pgrstResponse metrics  pgrst
 
     (ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
-      (planTime', iPlan) <- withTiming $ liftEither $ Plan.inspectPlan conf apiReq
+      (planTime', iPlan) <- withTiming $ liftEither $ Plan.inspectPlan apiReq
       (rsTime', oaiResult) <- withTiming $ runQuery roleIsoLvl (Plan.ipTxmode iPlan) $ Query.openApiQuery sCache pgVer conf tSchema
       (renderTime', pgrst) <- withTiming $ liftEither $ Response.openApiResponse (T.decodeUtf8 prettyVersion, docsVersion) headersOnly oaiResult conf sCache iSchema iNegotiatedByProfile
       let metrics = Map.fromList [(SMPlan, planTime'), (SMQuery, rsTime'), (SMRender, renderTime'), jwtTime]

src/PostgREST/MediaType.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 module PostgREST.MediaType
@@ -32,30 +33,18 @@ data MediaType
   | MTOther ByteString
   -- TODO MTPlan should only have its options as [Text]. Its ResultAggregate should have the typed attributes.
   | MTPlan MediaType MTPlanFormat [MTPlanOption]
-  deriving Show
-instance Eq MediaType where
-  MTApplicationJSON    == MTApplicationJSON = True
-  MTArrayJSONStrip     == MTArrayJSONStrip  = True
-  MTSingularJSON x     == MTSingularJSON y  = x == y
-  MTGeoJSON            == MTGeoJSON         = True
-  MTTextCSV            == MTTextCSV         = True
-  MTTextPlain          == MTTextPlain       = True
-  MTTextXML            == MTTextXML         = True
-  MTOpenAPI            == MTOpenAPI         = True
-  MTUrlEncoded         == MTUrlEncoded      = True
-  MTOctetStream        == MTOctetStream     = True
-  MTAny                == MTAny             = True
-  MTOther x            == MTOther y         = x == y
-  MTPlan{}             == MTPlan{}          = True
-  _                    == _                 = False
+  deriving (Eq, Show, Generic)
+instance Hashable MediaType
 
 data MTPlanOption
   = PlanAnalyze | PlanVerbose | PlanSettings | PlanBuffers | PlanWAL
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
+instance Hashable MTPlanOption
 
 data MTPlanFormat
   = PlanJSON | PlanText
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
+instance Hashable MTPlanFormat
 
 -- | Convert MediaType to a Content-Type HTTP Header
 toContentType :: MediaType -> Header

src/PostgREST/Plan.hs

@@ -44,15 +44,15 @@ import PostgREST.ApiRequest                  (Action (..),
                                               Payload (..))
 import PostgREST.Config                      (AppConfig (..))
 import PostgREST.Error                       (Error (..))
-import PostgREST.MediaType                   (MTPlanFormat (..),
-                                              MediaType (..))
+import PostgREST.MediaType                   (MediaType (..))
 import PostgREST.Query.SqlFragment           (sourceCTEName)
 import PostgREST.RangeQuery                  (NonnegRange, allRange,
                                               convertToLimitZeroRange,
                                               restrictRange)
 import PostgREST.SchemaCache                 (SchemaCache (..))
 import PostgREST.SchemaCache.Identifiers     (FieldName,
                                               QualifiedIdentifier (..),
+                                              RelIdentifier (..),
                                               Schema)
 import PostgREST.SchemaCache.Relationship    (Cardinality (..),
                                               Junction (..),
@@ -122,17 +122,17 @@ data InspectPlan = InspectPlan {
 wrappedReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> Either Error WrappedReadPlan
 wrappedReadPlan  identifier conf sCache apiRequest@ApiRequest{iPreferences=Preferences{..},..} = do
   rPlan <- readPlan identifier conf sCache apiRequest
-  mediaType <- mapLeft ApiRequestError $ negotiateContent conf iAction iAcceptMediaType
+  (rAgg, mediaType)  <- mapLeft ApiRequestError $ negotiateContent conf apiRequest identifier iAcceptMediaType (dbMediaAggs sCache)
   if not (null invalidPrefs) && preferHandling == Just Strict then Left $ ApiRequestError $ InvalidPreferences invalidPrefs else Right ()
-  return $ WrappedReadPlan rPlan SQL.Read (mediaToAggregate mediaType apiRequest) mediaType
+  return $ WrappedReadPlan rPlan SQL.Read rAgg mediaType
 
 mutateReadPlan :: Mutation -> ApiRequest -> QualifiedIdentifier -> AppConfig -> SchemaCache -> Either Error MutateReadPlan
 mutateReadPlan  mutation apiRequest@ApiRequest{iPreferences=Preferences{..},..} identifier conf sCache = do
   rPlan <- readPlan identifier conf sCache apiRequest
   mPlan <- mutatePlan mutation identifier apiRequest sCache rPlan
-  mediaType <- mapLeft ApiRequestError $ negotiateContent conf iAction iAcceptMediaType
   if not (null invalidPrefs) && preferHandling == Just Strict then Left $ ApiRequestError $ InvalidPreferences invalidPrefs else Right ()
-  return $ MutateReadPlan rPlan mPlan SQL.Write (mediaToAggregate mediaType apiRequest) mediaType
+  (rAgg, mediaType)  <- mapLeft ApiRequestError $ negotiateContent conf apiRequest identifier iAcceptMediaType (dbMediaAggs sCache)
+  return $ MutateReadPlan rPlan mPlan SQL.Write rAgg mediaType
 
 callReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> InvokeMethod -> Either Error CallReadPlan
 callReadPlan identifier conf sCache apiRequest@ApiRequest{iPreferences=Preferences{..},..} invMethod = do
@@ -156,15 +156,19 @@ callReadPlan identifier conf sCache apiRequest@ApiRequest{iPreferences=Preferenc
           (InvPost, Routine.Immutable) -> SQL.Read
           (InvPost, Routine.Volatile)  -> SQL.Write
       cPlan = callPlan proc apiRequest paramKeys args rPlan
-  mediaType <- mapLeft ApiRequestError $ negotiateContent conf iAction iAcceptMediaType
+  (rAgg, mediaType)  <- mapLeft ApiRequestError $ negotiateContent conf apiRequest relIdentifier iAcceptMediaType (dbMediaAggs sCache)
   if not (null invalidPrefs) && preferHandling == Just Strict then Left $ ApiRequestError $ InvalidPreferences invalidPrefs else Right ()
-  return $ CallReadPlan rPlan cPlan txMode proc (mediaToAggregate mediaType apiRequest) mediaType
+  return $ CallReadPlan rPlan cPlan txMode proc rAgg mediaType
   where
     qsParams' = QueryParams.qsParams iQueryParams
 
-inspectPlan :: AppConfig -> ApiRequest -> Either Error InspectPlan
-inspectPlan conf apiRequest = do
-  mediaType <- mapLeft ApiRequestError $ negotiateContent conf (iAction apiRequest) (iAcceptMediaType apiRequest)
+inspectPlan :: ApiRequest -> Either Error InspectPlan
+inspectPlan apiRequest = do
+  let producedMTs = [MTOpenAPI, MTApplicationJSON, MTAny]
+      accepts     = iAcceptMediaType apiRequest
+  mediaType <- if not . null $ L.intersect accepts producedMTs
+    then Right MTOpenAPI
+    else Left . ApiRequestError . MediaTypeError $ MediaType.toMime <$> accepts
   return $ InspectPlan mediaType SQL.Read
 
 {-|
@@ -824,52 +828,29 @@ inferColsEmbedNeeds (Node ReadPlan{select} forest) pkCols
 addFilterToLogicForest :: CoercibleFilter -> [CoercibleLogicTree] -> [CoercibleLogicTree]
 addFilterToLogicForest flt lf = CoercibleStmnt flt : lf
 
-mediaToAggregate :: MediaType -> ApiRequest -> ResultAggregate
-mediaToAggregate mt apiReq@ApiRequest{iAction=act, iPreferences=Preferences{preferRepresentation=rep}} =
-  if noAgg then NoAgg
-  else case mt of
-    MTApplicationJSON     -> BuiltinAggJson
-    MTSingularJSON strip  -> BuiltinAggSingleJson strip
-    MTArrayJSONStrip      -> BuiltinAggArrayJsonStrip
-    MTGeoJSON             -> BuiltinAggGeoJson
-    MTTextCSV             -> BuiltinAggCsv
-    MTAny                 -> BuiltinAggJson
-    MTOpenAPI             -> BuiltinAggJson
-    MTUrlEncoded          -> NoAgg -- TODO: unreachable since a previous step (producedMediaTypes) whitelists the media types that can become aggregates.
-
-    -- Doing `Accept: application/vnd.pgrst.plan; for="application/vnd.pgrst.plan"` doesn't make sense, so we just empty the body.
-    -- TODO: fail instead to be more strict
-    MTPlan (MTPlan{}) _ _ -> NoAgg
-    MTPlan media      _ _ -> mediaToAggregate media apiReq
-    _                     -> NoAgg
-  where
-    noAgg = case act of
-      ActionMutate _         -> rep == Just HeadersOnly || rep == Just None || isNothing rep
-      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 -> [MediaType] -> Either ApiRequestError MediaType
-negotiateContent conf action 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
+negotiateContent :: AppConfig -> ApiRequest -> QualifiedIdentifier -> [MediaType] ->
+                    HM.HashMap (RelIdentifier, MediaType) ResultAggregate -> Either ApiRequestError (ResultAggregate, MediaType)
+negotiateContent conf ApiRequest{iAction=act, iPreferences=Preferences{preferRepresentation=rep}} identifier accepts produces =
+  case (act, firstAcceptedPick) of
+    (_, Nothing)                         -> Left . MediaTypeError $ map MediaType.toMime accepts
+    (ActionMutate _, Just (x, mt))       -> Right (if rep == Just Full then x else NoAgg, mtAnyToJson mt)
+    -- no need for an aggregate on HEAD https://github.com/PostgREST/postgrest/issues/2849
+    -- TODO: despite no aggregate, these are responding with a Content-Type, which is not correct.
+    (ActionRead True, Just (_, mt))      -> Right (NoAgg, mtAnyToJson mt)
+    (ActionInvoke InvHead, Just (_, mt)) -> Right (NoAgg, mtAnyToJson mt)
+    (_, Just (x, mt))                    -> Right (x, mtAnyToJson mt)
   where
+    mtAnyToJson _mt = if _mt == MTAny then MTApplicationJSON else _mt -- by default(for */*) we respond with json
     -- if there are multiple accepted media types, pick the first
-    firstAcceptedPick = listToMaybe $ L.intersect accepts $ producedMediaTypes conf action
-
-producedMediaTypes :: AppConfig -> Action -> [MediaType]
-producedMediaTypes conf action =
-  case action of
-    ActionRead _    -> defaultMediaTypes
-    ActionInvoke _  -> defaultMediaTypes
-    ActionInfo      -> defaultMediaTypes
-    ActionMutate _  -> defaultMediaTypes
-    ActionInspect _ -> inspectMediaTypes
-  where
-    inspectMediaTypes = [MTOpenAPI, MTApplicationJSON, MTArrayJSONStrip, MTAny]
-    defaultMediaTypes =
-      [MTApplicationJSON, MTArrayJSONStrip, MTSingularJSON True, MTSingularJSON False, MTGeoJSON, MTTextCSV] ++
-      [MTPlan MTApplicationJSON PlanText mempty | configDbPlanEnabled conf] ++ [MTAny]
+    firstAcceptedPick = listToMaybe $ mapMaybe searchMT accepts
+    lookupIdent mt = -- first search for an aggregate that applies to the particular relation, then for one that applies to anyelement
+      HM.lookup (RelId identifier, mt) produces <|> HM.lookup (RelAnyElement, mt) produces
+    searchMT mt = case mt of
+      m@(MTSingularJSON strip)              -> Just (BuiltinAggSingleJson strip, m)
+      m@MTArrayJSONStrip                    -> Just (BuiltinAggArrayJsonStrip, m)
+      m@(MTPlan (MTSingularJSON strip) _ _) -> mtPlanToNothing $ Just (BuiltinAggSingleJson strip, m)
+      m@(MTPlan MTArrayJSONStrip _ _)       -> mtPlanToNothing $ Just (BuiltinAggArrayJsonStrip, m)
+      m@(MTPlan mType _ _)                  -> mtPlanToNothing $ (,) <$> lookupIdent mType <*> pure m
+      x                                     -> (,) <$> lookupIdent x <*> pure x
+    mtPlanToNothing x = if configDbPlanEnabled conf then x else Nothing

src/PostgREST/Query/SqlFragment.hs

@@ -212,6 +212,17 @@ asJsonF rout strip
 asGeoJsonF ::  SQL.Snippet
 asGeoJsonF = "json_build_object('type', 'FeatureCollection', 'features', coalesce(json_agg(ST_AsGeoJSON(_postgrest_t)::json), '[]'))"
 
+customAggF :: Maybe Routine -> QualifiedIdentifier -> SQL.Snippet
+customAggF rout qi
+  | returnsSingleComposite    = fromQi qi <> "(_postgrest_t)"
+  | returnsScalar             = fromQi qi <> "(_postgrest_t.pgrst_scalar)"
+  | returnsSetOfScalar        = fromQi qi <> "(_postgrest_t.pgrst_scalar)"
+  | otherwise                 = fromQi qi <> "(_postgrest_t)"
+  where
+    (returnsSingleComposite, returnsScalar, returnsSetOfScalar) = case rout of
+      Just r  -> (funcReturnsSingleComposite r, funcReturnsScalar r, funcReturnsSetOfScalar r)
+      Nothing -> (False, False, False)
+
 locationF :: [Text] -> SQL.Snippet
 locationF pKeys = [qc|(
   WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1)
@@ -493,4 +504,5 @@ aggF rout = \case
   BuiltinAggSingleJson strip -> asJsonSingleF rout strip
   BuiltinAggGeoJson          -> asGeoJsonF
   BuiltinAggCsv              -> asCsvF
+  CustomAgg qi               -> customAggF rout qi
   NoAgg                      -> "''::text"