test: cannot override vendored media types

src/PostgREST/Error.hs

@@ -91,7 +91,7 @@ instance PgrstError ApiRequestError where
   status SingularityError{}      = HTTP.status406
   status PGRSTParseError         = HTTP.status500
 
-  headers SingularityError{}     = [MediaType.toContentType $ MTSingularJSON False]
+  headers SingularityError{}     = [MediaType.toContentType $ MTVndSingularJSON False]
   headers _ = mempty
 
 toJsonPgrstError :: ErrorCode -> Text -> Maybe JSON.Value -> Maybe JSON.Value -> JSON.Value

src/PostgREST/MediaType.hs

@@ -3,8 +3,8 @@
 
 module PostgREST.MediaType
   ( MediaType(..)
-  , MTPlanOption (..)
-  , MTPlanFormat (..)
+  , MTVndPlanOption (..)
+  , MTVndPlanFormat (..)
   , toContentType
   , toMime
   , decodeMediaType
@@ -20,8 +20,6 @@ import Protolude
 -- | Enumeration of currently supported media types
 data MediaType
   = MTApplicationJSON
-  | MTArrayJSONStrip
-  | MTSingularJSON Bool
   | MTGeoJSON
   | MTTextCSV
   | MTTextPlain
@@ -31,20 +29,23 @@ data MediaType
   | MTOctetStream
   | MTAny
   | MTOther ByteString
-  -- TODO MTPlan should only have its options as [Text]. Its ResultAggregate should have the typed attributes.
-  | MTPlan MediaType MTPlanFormat [MTPlanOption]
+  -- vendored media types
+  | MTVndArrayJSONStrip
+  | MTVndSingularJSON Bool
+  -- TODO MTVndPlan should only have its options as [Text]. Its ResultAggregate should have the typed attributes.
+  | MTVndPlan MediaType MTVndPlanFormat [MTVndPlanOption]
   deriving (Eq, Show, Generic)
 instance Hashable MediaType
 
-data MTPlanOption
+data MTVndPlanOption
   = PlanAnalyze | PlanVerbose | PlanSettings | PlanBuffers | PlanWAL
   deriving (Eq, Show, Generic)
-instance Hashable MTPlanOption
+instance Hashable MTVndPlanOption
 
-data MTPlanFormat
+data MTVndPlanFormat
   = PlanJSON | PlanText
   deriving (Eq, Show, Generic)
-instance Hashable MTPlanFormat
+instance Hashable MTVndPlanFormat
 
 -- | Convert MediaType to a Content-Type HTTP Header
 toContentType :: MediaType -> Header
@@ -58,31 +59,31 @@ toContentType ct = (hContentType, toMime ct <> charset)
 -- | Convert from MediaType to a ByteString representing the mime type
 toMime :: MediaType -> ByteString
 toMime MTApplicationJSON      = "application/json"
-toMime MTArrayJSONStrip       = "application/vnd.pgrst.array+json;nulls=stripped"
+toMime MTVndArrayJSONStrip       = "application/vnd.pgrst.array+json;nulls=stripped"
 toMime MTGeoJSON              = "application/geo+json"
 toMime MTTextCSV              = "text/csv"
 toMime MTTextPlain            = "text/plain"
 toMime MTTextXML              = "text/xml"
 toMime MTOpenAPI              = "application/openapi+json"
-toMime (MTSingularJSON True)  = "application/vnd.pgrst.object+json;nulls=stripped"
-toMime (MTSingularJSON False) = "application/vnd.pgrst.object+json"
+toMime (MTVndSingularJSON True)  = "application/vnd.pgrst.object+json;nulls=stripped"
+toMime (MTVndSingularJSON False) = "application/vnd.pgrst.object+json"
 toMime MTUrlEncoded           = "application/x-www-form-urlencoded"
 toMime MTOctetStream          = "application/octet-stream"
 toMime MTAny                  = "*/*"
 toMime (MTOther ct)           = ct
-toMime (MTPlan mt fmt opts)   =
+toMime (MTVndPlan mt fmt opts)   =
   "application/vnd.pgrst.plan+" <> toMimePlanFormat fmt <>
   ("; for=\"" <> toMime mt <> "\"") <>
   (if null opts then mempty else "; options=" <> BS.intercalate "|" (toMimePlanOption <$> opts))
 
-toMimePlanOption :: MTPlanOption -> ByteString
+toMimePlanOption :: MTVndPlanOption -> ByteString
 toMimePlanOption PlanAnalyze  = "analyze"
 toMimePlanOption PlanVerbose  = "verbose"
 toMimePlanOption PlanSettings = "settings"
 toMimePlanOption PlanBuffers  = "buffers"
 toMimePlanOption PlanWAL      = "wal"
 
-toMimePlanFormat :: MTPlanFormat -> ByteString
+toMimePlanFormat :: MTVndPlanFormat -> ByteString
 toMimePlanFormat PlanJSON = "json"
 toMimePlanFormat PlanText = "text"
 
@@ -92,25 +93,25 @@ toMimePlanFormat PlanText = "text"
 -- MTApplicationJSON
 --
 -- >>> decodeMediaType "application/vnd.pgrst.plan;"
--- MTPlan MTApplicationJSON PlanText []
+-- MTVndPlan MTApplicationJSON PlanText []
 --
 -- >>> decodeMediaType "application/vnd.pgrst.plan;for=\"application/json\""
--- MTPlan MTApplicationJSON PlanText []
+-- MTVndPlan MTApplicationJSON PlanText []
 --
 -- >>> decodeMediaType "application/vnd.pgrst.plan+json;for=\"text/csv\""
--- MTPlan MTTextCSV PlanJSON []
+-- MTVndPlan MTTextCSV PlanJSON []
 --
 -- >>> decodeMediaType "application/vnd.pgrst.array+json;nulls=stripped"
--- MTArrayJSONStrip
+-- MTVndArrayJSONStrip
 --
 -- >>> decodeMediaType "application/vnd.pgrst.array+json"
 -- MTApplicationJSON
 --
 -- >>> decodeMediaType "application/vnd.pgrst.object+json;nulls=stripped"
--- MTSingularJSON True
+-- MTVndSingularJSON True
 --
 -- >>> decodeMediaType "application/vnd.pgrst.object+json"
--- MTSingularJSON False
+-- MTVndSingularJSON False
 
 decodeMediaType :: BS.ByteString -> MediaType
 decodeMediaType mt =
@@ -134,11 +135,11 @@ decodeMediaType mt =
     other:_                                  -> MTOther other
     _                                        -> MTAny
   where
-    checkArrayNullStrip ["nulls=stripped"] = MTArrayJSONStrip
+    checkArrayNullStrip ["nulls=stripped"] = MTVndArrayJSONStrip
     checkArrayNullStrip  _                 = MTApplicationJSON
 
-    checkSingularNullStrip ["nulls=stripped"] = MTSingularJSON True
-    checkSingularNullStrip  _                 = MTSingularJSON False
+    checkSingularNullStrip ["nulls=stripped"] = MTVndSingularJSON True
+    checkSingularNullStrip  _                 = MTVndSingularJSON False
 
     getPlan fmt rest =
       let
@@ -150,7 +151,7 @@ decodeMediaType mt =
           strippedFor <- BS.stripPrefix "for=" foundFor
           pure . decodeMediaType $ dropAround (== BS.c2w '"') strippedFor
       in
-      MTPlan mtFor fmt $
+      MTVndPlan mtFor fmt $
         [PlanAnalyze  | inOpts "analyze" ] ++
         [PlanVerbose  | inOpts "verbose" ] ++
         [PlanSettings | inOpts "settings"] ++

src/PostgREST/Plan.hs

@@ -835,25 +835,30 @@ addFilterToLogicForest flt lf = CoercibleStmnt flt : lf
 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
+  mtAnyToJSON $ 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)
+    (ActionMutate _, Just (x, mt))       -> Right (if rep == Just Full then x else NoAgg, 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)
+    (ActionRead True, Just (_, mt))      -> Right (NoAgg, mt)
+    (ActionInvoke InvHead, Just (_, mt)) -> Right (NoAgg, mt)
+    (_, Just (x, mt))                    -> Right (x, mt)
   where
-    mtAnyToJson _mt = if _mt == MTAny then MTApplicationJSON else _mt -- by default(for */*) we respond with json
+    -- TODO initial */* is not overridable
+    -- initial handlers in the schema cache have a */* to BuiltinAggJson but they don't preserve the media type (application/json)
+    -- for now we just convert the resultant */* to application/json here
+    mtAnyToJSON = mapRight (\(x, y) -> (x, if y == MTAny then MTApplicationJSON else y))
     -- if there are multiple accepted media types, pick the first
     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
+      -- all the vendored media types have special handling as they have media type parameters, they cannot be overridden
+      m@(MTVndSingularJSON strip)                 -> Just (BuiltinAggSingleJson strip, m)
+      m@MTVndArrayJSONStrip                       -> Just (BuiltinAggArrayJsonStrip, m)
+      m@(MTVndPlan (MTVndSingularJSON strip) _ _) -> mtPlanToNothing $ Just (BuiltinAggSingleJson strip, m)
+      m@(MTVndPlan MTVndArrayJSONStrip _ _)       -> mtPlanToNothing $ Just (BuiltinAggArrayJsonStrip, m)
+      -- all the other media types can be overridden
+      m@(MTVndPlan mType _ _)                     -> mtPlanToNothing $ (,) <$> lookupIdent mType <*> pure m
+      x                                           -> (,) <$> lookupIdent x <*> pure x
+    mtPlanToNothing x = if configDbPlanEnabled conf then x else Nothing -- don't find anything if the plan media type is not allowed

src/PostgREST/Query.hs

@@ -210,7 +210,7 @@ writeQuery MutateReadPlan{mrReadPlan, mrMutatePlan, mrResAgg, mrMedia, mrIdent}
 failNotSingular :: MediaType -> ResultSet -> DbHandler ()
 failNotSingular _ RSPlan{} = pure ()
 failNotSingular mediaType RSStandard{rsQueryTotal=queryTotal} =
-  when (elem mediaType [MTSingularJSON True,MTSingularJSON False] && queryTotal /= 1) $ do
+  when (elem mediaType [MTVndSingularJSON True, MTVndSingularJSON False] && queryTotal /= 1) $ do
     lift SQL.condemn
     throwError $ Error.ApiRequestError . ApiRequestTypes.SingularityError $ toInteger queryTotal
 

src/PostgREST/Query/SqlFragment.hs

@@ -65,8 +65,8 @@ import PostgREST.ApiRequest.Types        (Alias, Cast,
                                           QuantOperator (..),
                                           SimpleOperator (..),
                                           TrileanVal (..))
-import PostgREST.MediaType               (MTPlanFormat (..),
-                                          MTPlanOption (..))
+import PostgREST.MediaType               (MTVndPlanFormat (..),
+                                          MTVndPlanOption (..))
 import PostgREST.Plan.ReadPlan           (JoinCondition (..))
 import PostgREST.Plan.Types              (CoercibleField (..),
                                           CoercibleFilter (..),
@@ -460,13 +460,13 @@ intercalateSnippet :: ByteString -> [SQL.Snippet] -> SQL.Snippet
 intercalateSnippet _ [] = mempty
 intercalateSnippet frag snippets = foldr1 (\a b -> a <> SQL.sql frag <> b) snippets
 
-explainF :: MTPlanFormat -> [MTPlanOption] -> SQL.Snippet -> SQL.Snippet
+explainF :: MTVndPlanFormat -> [MTVndPlanOption] -> SQL.Snippet -> SQL.Snippet
 explainF fmt opts snip =
   "EXPLAIN (" <>
     SQL.sql (BS.intercalate ", " (fmtPlanFmt fmt : (fmtPlanOpt <$> opts))) <>
   ") " <> snip
   where
-    fmtPlanOpt :: MTPlanOption -> BS.ByteString
+    fmtPlanOpt :: MTVndPlanOption -> BS.ByteString
     fmtPlanOpt PlanAnalyze  = "ANALYZE"
     fmtPlanOpt PlanVerbose  = "VERBOSE"
     fmtPlanOpt PlanSettings = "SETTINGS"
@@ -493,10 +493,10 @@ setConfigLocalJson prefix keyVals = [setConfigLocal mempty (prefix, gucJsonVal k
 
 aggF :: Maybe Routine -> QualifiedIdentifier -> ResultAggregate -> SQL.Snippet
 aggF rout target = \case
-  BuiltinAggJson             -> asJsonF rout False
   BuiltinAggArrayJsonStrip   -> asJsonF rout True
   BuiltinAggSingleJson strip -> asJsonSingleF rout strip
-  BuiltinAggGeoJson          -> asGeoJsonF
-  BuiltinAggCsv              -> asCsvF
+  BuiltinOvAggJson           -> asJsonF rout False
+  BuiltinOvAggGeoJson        -> asGeoJsonF
+  BuiltinOvAggCsv            -> asCsvF
   CustomAgg funcQi           -> customAggF rout funcQi target
   NoAgg                      -> "''::text"

src/PostgREST/Query/Statements.hs

@@ -25,7 +25,7 @@ import qualified Hasql.Statement                   as SQL
 import Control.Lens ((^?))
 
 import PostgREST.ApiRequest.Preferences
-import PostgREST.MediaType               (MTPlanFormat (..),
+import PostgREST.MediaType               (MTVndPlanFormat (..),
                                           MediaType (..))
 import PostgREST.Query.SqlFragment
 import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier)
@@ -86,7 +86,7 @@ prepareWrite qi selectQuery mutateQuery isInsert mt rAgg rep pKeys =
 
   decodeIt :: HD.Result ResultSet
   decodeIt = case mt of
-    MTPlan{} -> planRow
+    MTVndPlan{} -> planRow
     _        -> fromMaybe (RSStandard Nothing 0 mempty mempty Nothing Nothing) <$> HD.rowMaybe (standardRow False)
 
 prepareRead :: QualifiedIdentifier -> SQL.Snippet -> SQL.Snippet -> Bool -> MediaType -> ResultAggregate -> Bool -> SQL.Statement () ResultSet
@@ -108,8 +108,8 @@ prepareRead qi selectQuery countQuery countTotal mt rAgg =
 
   decodeIt :: HD.Result ResultSet
   decodeIt = case mt of
-    MTPlan{} -> planRow
-    _        -> HD.singleRow $ standardRow True
+    MTVndPlan{} -> planRow
+    _           -> HD.singleRow $ standardRow True
 
 prepareCall :: QualifiedIdentifier -> Routine -> SQL.Snippet -> SQL.Snippet -> SQL.Snippet -> Bool ->
                MediaType -> ResultAggregate -> Bool ->
@@ -134,7 +134,7 @@ prepareCall qi rout callProcQuery selectQuery countQuery countTotal mt rAgg =
 
     decodeIt :: HD.Result ResultSet
     decodeIt = case mt of
-      MTPlan{} -> planRow
+      MTVndPlan{} -> planRow
       _        -> fromMaybe (RSStandard (Just 0) 0 mempty mempty Nothing Nothing) <$> HD.rowMaybe (standardRow True)
 
 preparePlanRows :: SQL.Snippet -> Bool -> SQL.Statement () (Maybe Int64)
@@ -161,8 +161,8 @@ standardRow noLocation =
 
 mtSnippet :: MediaType -> SQL.Snippet -> SQL.Snippet
 mtSnippet mediaType snippet = case mediaType of
-  MTPlan _ fmt opts -> explainF fmt opts snippet
-  _                 -> snippet
+  MTVndPlan _ fmt opts -> explainF fmt opts snippet
+  _                    -> snippet
 
 -- | We use rowList because when doing EXPLAIN (FORMAT TEXT), the result comes as many rows. FORMAT JSON comes as one.
 planRow :: HD.Result ResultSet

src/PostgREST/Response/OpenAPI.hs

@@ -350,7 +350,7 @@ makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
       & summary .~ pSum
       & description .~ mfilter (/="") pDesc
       & tags .~ Set.fromList ["(rpc) " <> pdName pd]
-      & produces ?~ makeMimeList [MTApplicationJSON, MTSingularJSON True, MTSingularJSON False]
+      & produces ?~ makeMimeList [MTApplicationJSON, MTVndSingularJSON True, MTVndSingularJSON False]
       & at 200 ?~ "OK"
     getOp = procOp
       & parameters .~ makeProcGetParams (pdParams pd)
@@ -406,8 +406,8 @@ postgrestSpec (prettyVersion, docsVersion) rels pds ti (s, h, p, b) sd allowSecu
   & definitions .~ fromList (makeTableDef rels <$> ti)
   & parameters .~ fromList (makeParamDefs ti)
   & paths .~ makePathItems pds ti
-  & produces .~ makeMimeList [MTApplicationJSON, MTSingularJSON True, MTSingularJSON False, MTTextCSV]
-  & consumes .~ makeMimeList [MTApplicationJSON, MTSingularJSON True, MTSingularJSON False, MTTextCSV]
+  & produces .~ makeMimeList [MTApplicationJSON, MTVndSingularJSON True, MTVndSingularJSON False, MTTextCSV]
+  & consumes .~ makeMimeList [MTApplicationJSON, MTVndSingularJSON True, MTVndSingularJSON False, MTTextCSV]
   & securityDefinitions .~ makeSecurityDefinitions securityDefName allowSecurityDef
   & security .~ [SecurityRequirement (fromList [(securityDefName, [])]) | allowSecurityDef]
     where

src/PostgREST/SchemaCache.hs

@@ -1105,18 +1105,16 @@ allViewsKeyDependencies =
 
 initialMediaAggregates :: MediaAggregateMap
 initialMediaAggregates =
-  HM.insert (RelAnyElement, MediaType.MTAny            ) BuiltinAggJson $
-  HM.insert (RelAnyElement, MediaType.MTApplicationJSON) BuiltinAggJson $
-  HM.insert (RelAnyElement, MediaType.MTTextCSV        ) BuiltinAggCsv $
-  HM.insert (RelAnyElement, MediaType.MTGeoJSON        ) BuiltinAggGeoJson
+  HM.insert (RelAnyElement, MediaType.MTAny            ) BuiltinOvAggJson $
+  HM.insert (RelAnyElement, MediaType.MTApplicationJSON) BuiltinOvAggJson $
+  HM.insert (RelAnyElement, MediaType.MTTextCSV        ) BuiltinOvAggCsv $
+  HM.insert (RelAnyElement, MediaType.MTGeoJSON        ) BuiltinOvAggGeoJson
   HM.empty
 
 mediaAggregates :: PgVersion -> Bool -> SQL.Statement [Schema] MediaAggregateMap
 mediaAggregates pgVer =
   SQL.Statement sql (arrayParam HE.text) decodeMediaAggregates
   where
-    -- pg_aggregate doesn't contain the parameters of the aggreate and other things, we need to use pg_proc for getting these
-    -- only obtain aggregates which have a single parameter that is a relation or anyelement
     sql = [q|
       with
       all_relations as (

src/PostgREST/SchemaCache/Routine.hs

@@ -93,11 +93,14 @@ instance Ord Routine where
 type RoutineMap = HM.HashMap QualifiedIdentifier [Routine]
 
 data ResultAggregate
-   = BuiltinAggJson
-   | BuiltinAggSingleJson Bool
+   -- non overridable builtins
+   = BuiltinAggSingleJson Bool
    | BuiltinAggArrayJsonStrip
-   | BuiltinAggGeoJson
-   | BuiltinAggCsv
+   -- these builtins are overridable
+   | BuiltinOvAggJson
+   | BuiltinOvAggGeoJson
+   | BuiltinOvAggCsv
+   -- custom
    | CustomAgg QualifiedIdentifier
    | NoAgg
    deriving (Eq, Show)

test/spec/Feature/Query/CustomMediaSpec.hs

@@ -174,3 +174,11 @@ spec = describe "custom media types" $ do
         { matchStatus  = 200
         , matchHeaders = ["Content-Type" <:> "application/geo+json; charset=utf-8"]
         }
+
+    it "will not override vendored media types like application/vnd.pgrst.object" $
+      request methodGet "/projects?id=eq.1" (acceptHdrs "application/vnd.pgrst.object") ""
+        `shouldRespondWith`
+        [json|{"id":1,"name":"Windows 7","client_id":1}|]
+        { matchStatus  = 200
+        , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"]
+        }

test/spec/fixtures/schema.sql

@@ -129,6 +129,7 @@ create domain "application/openapi+json" as json;
 create domain "application/geo+json" as jsonb;
 create domain "application/vnd.geo2+json" as jsonb;
 create domain "application/json" as json;
+create domain "application/vnd.pgrst.object" as json;
 
 CREATE TABLE items (
     id bigserial primary key
@@ -3645,3 +3646,16 @@ create aggregate test.lines_geojson_agg (test.lines) (
 , sfunc = lines_geojson_trans
 , finalfunc = lines_geojson_final
 );
+
+-- override application/vnd.pgrst.object
+create or replace function test.pgrst_obj_json_trans (state "application/vnd.pgrst.object", next anyelement)
+returns "application/vnd.pgrst.object" as $$
+  select null;
+$$ language sql;
+
+drop aggregate if exists test.pgrst_obj_agg(anyelement);
+create aggregate test.pgrst_obj_agg(anyelement) (
+  initcond = '{"overridden": "true"}'
+, stype = "application/vnd.pgrst.object"
+, sfunc = pgrst_obj_json_trans
+);