refactor: plan media type

src/PostgREST/ApiRequest.hs

@@ -53,7 +53,8 @@ import PostgREST.Config                  (AppConfig (..),
                                           OpenAPIMode (..))
 import PostgREST.MediaType               (MTPlanAttrs (..),
                                           MTPlanFormat (..),
-                                          MediaType (..))
+                                          MediaType (..),
+                                          NormalMedia (..))
 import PostgREST.RangeQuery              (NonnegRange, allRange,
                                           convertToLimitZeroRange,
                                           hasLimitZero,
@@ -210,8 +211,8 @@ 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"
+    accepts = maybe [MTNormal MTAny] (map MediaType.decodeMediaType . parseHttpAccept) $ lookupHeader "accept"
+    contentMediaType = maybe (MTNormal MTApplicationJSON) MediaType.decodeMediaType $ lookupHeader "content-type"
     lookupHeader    = flip lookup hdrs
 
 getSchema :: AppConfig -> RequestHeaders -> ByteString -> Either ApiRequestError (Schema, Bool)
@@ -264,26 +265,26 @@ getPayload reqBody contentMediaType QueryParams{qsColumns} action PathInfo{pathI
   where
     payload :: Either ApiRequestError (Maybe Payload)
     payload = mapBoth InvalidBody Just $ case (contentMediaType, pathIsProc) of
-      (MTApplicationJSON, _) ->
+      (MTNormal MTApplicationJSON, _) ->
         if isJust columns
           then Right $ RawJSON reqBody
           else note "All object keys must match" . payloadAttributes reqBody
                  =<< if LBS.null reqBody && pathIsProc
                        then Right emptyObject
                        else first BS.pack $ JSON.eitherDecode reqBody
-      (MTTextCSV, _) -> do
+      (MTNormal MTTextCSV, _) -> do
         json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody)
         note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
-      (MTUrlEncoded, isProc) -> do
+      (MTNormal MTUrlEncoded, isProc) -> do
         let params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
         if isProc
           then Right $ ProcessedUrlEncoded params (S.fromList $ fst <$> params)
           else
             let paramsMap = HM.fromList $ (identity *** JSON.String) <$> params in
             Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (HM.keys paramsMap)
-      (MTTextPlain, True) -> Right $ RawPay reqBody
-      (MTTextXML, True) -> Right $ RawPay reqBody
-      (MTOctetStream, True) -> Right $ RawPay reqBody
+      (MTNormal MTTextPlain, True) -> Right $ RawPay reqBody
+      (MTNormal MTTextXML, True) -> Right $ RawPay reqBody
+      (MTNormal MTOctetStream, True) -> Right $ RawPay reqBody
       (ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
 
     shouldParsePayload = case (action, contentMediaType) of
@@ -353,9 +354,9 @@ payloadAttributes raw json =
 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
+    Just (MTNormal MTAny) -> Right (MTNormal 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
@@ -365,15 +366,15 @@ producedMediaTypes conf action path =
   case action of
     ActionRead _    -> defaultMediaTypes ++ rawMediaTypes
     ActionInvoke _  -> invokeMediaTypes
-    ActionInspect _ -> [MTOpenAPI, MTApplicationJSON, MTAny]
+    ActionInspect _ -> [MTNormal MTOpenAPI, MTNormal MTApplicationJSON, MTNormal MTAny]
     ActionInfo      -> defaultMediaTypes
     ActionMutate _  -> defaultMediaTypes
   where
     invokeMediaTypes =
       defaultMediaTypes
         ++ rawMediaTypes
-        ++ [MTOpenAPI | pathIsRootSpec path]
+        ++ [MTNormal MTOpenAPI | pathIsRootSpec path]
     defaultMediaTypes =
-      [MTApplicationJSON, MTSingularJSON, MTGeoJSON, MTTextCSV] ++
-      [MTPlan $ MTPlanAttrs Nothing PlanJSON mempty | configDbPlanEnabled conf] ++ [MTAny]
-    rawMediaTypes = configRawMediaTypes conf `union` [MTOctetStream, MTTextPlain, MTTextXML]
+      [MTNormal MTApplicationJSON, MTNormal MTSingularJSON, MTNormal MTGeoJSON, MTNormal MTTextCSV] ++
+      [MTPlan $ MTPlanAttrs Nothing PlanJSON mempty | configDbPlanEnabled conf] ++ [MTNormal MTAny]
+    rawMediaTypes = configRawMediaTypes conf `union` [MTNormal MTOctetStream, MTNormal MTTextPlain, MTNormal MTTextXML]

src/PostgREST/Config.hs

@@ -57,7 +57,8 @@ import PostgREST.Config.JSPath           (JSPath, JSPathExp (..),
                                           dumpJSPath, pRoleClaimKey)
 import PostgREST.Config.Proxy            (Proxy (..),
                                           isMalformedProxyUri, toURI)
-import PostgREST.MediaType               (MediaType (..), toMime)
+import PostgREST.MediaType               (MediaType (..),
+                                          NormalMedia (..), toMime)
 import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier, dumpQi,
                                           toQi)
 
@@ -262,7 +263,7 @@ parser optPath env dbSettings roleSettings roleIsolationLvl =
     <*> parseOpenAPIMode "openapi-mode"
     <*> (fromMaybe False <$> optBool "openapi-security-active")
     <*> parseOpenAPIServerProxyURI "openapi-server-proxy-uri"
-    <*> (maybe [] (fmap (MTOther . encodeUtf8) . splitOnCommas) <$> optValue "raw-media-types")
+    <*> (maybe [] (fmap (MTNormal . MTOther . encodeUtf8) . splitOnCommas) <$> optValue "raw-media-types")
     <*> (fromMaybe "!4" <$> optString "server-host")
     <*> (fromMaybe 3000 <$> optInt "server-port")
     <*> (fmap (CI.mk . encodeUtf8) <$> optString "server-trace-header")

src/PostgREST/Error.hs

@@ -33,7 +33,8 @@ import Network.HTTP.Types.Header (Header)
 import           PostgREST.ApiRequest.Types (ApiRequestError (..),
                                              QPError (..),
                                              RangeError (..))
-import           PostgREST.MediaType        (MediaType (..))
+import           PostgREST.MediaType        (MediaType (..),
+                                             NormalMedia (..))
 import qualified PostgREST.MediaType        as MediaType
 
 import PostgREST.SchemaCache.Identifiers  (QualifiedIdentifier (..),
@@ -81,7 +82,7 @@ instance PgrstError ApiRequestError where
   status LimitNoOrderError       = HTTP.status400
   status ColumnNotFound{}        = HTTP.status400
 
-  headers _ = [MediaType.toContentType MTApplicationJSON]
+  headers _ = [MediaType.toContentType $ MTNormal MTApplicationJSON]
 
 instance JSON.ToJSON ApiRequestError where
   toJSON (QueryParamError (QPError message details)) = JSON.object [
@@ -188,18 +189,18 @@ instance JSON.ToJSON ApiRequestError where
         prmsMsg = "(" <> prms <> ")"
         prmsDet = " with parameter" <> (if length argumentKeys > 1 then "s " else " ") <> prms
         fmtPrms p = if null argumentKeys then " without parameters" else p
-        onlySingleParams = hasPreferSingleObject || (isInvPost && contentType `elem` [MTTextPlain, MTTextXML, MTOctetStream])
+        onlySingleParams = hasPreferSingleObject || (isInvPost && contentType `elem` [MTNormal MTTextPlain, MTNormal MTTextXML, MTNormal MTOctetStream])
     in JSON.object [
     "code"    .= SchemaCacheErrorCode02,
     "message" .= ("Could not find the function " <> func <> (if onlySingleParams then "" else fmtPrms prmsMsg) <> " in the schema cache"),
     "details" .= ("Searched for the function " <> func <>
       (case (hasPreferSingleObject, isInvPost, contentType) of
-        (True, _, _)                 -> " with a single json/jsonb parameter"
-        (_, True, MTTextPlain)       -> " with a single unnamed text parameter"
-        (_, True, MTTextXML)         -> " with a single unnamed xml parameter"
-        (_, True, MTOctetStream)     -> " with a single unnamed bytea parameter"
-        (_, True, MTApplicationJSON) -> fmtPrms prmsDet <> " or with a single unnamed json/jsonb parameter"
-        _                            -> fmtPrms prmsDet) <>
+        (True, _, _)                          -> " with a single json/jsonb parameter"
+        (_, True, MTNormal MTTextPlain)       -> " with a single unnamed text parameter"
+        (_, True, MTNormal MTTextXML)         -> " with a single unnamed xml parameter"
+        (_, True, MTNormal MTOctetStream)     -> " with a single unnamed bytea parameter"
+        (_, True, MTNormal MTApplicationJSON) -> fmtPrms prmsDet <> " or with a single unnamed json/jsonb parameter"
+        _                                     -> fmtPrms prmsDet) <>
       ", but no matches were found in the schema cache."),
     -- The hint will be null in the case of single unnamed parameter functions
     "hint"    .= if onlySingleParams
@@ -361,8 +362,8 @@ instance PgrstError PgError where
 
   headers err =
     if status err == HTTP.status401
-       then [MediaType.toContentType MTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
-       else [MediaType.toContentType MTApplicationJSON]
+       then [MediaType.toContentType $ MTNormal MTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
+       else [MediaType.toContentType $ MTNormal MTApplicationJSON]
 
 instance JSON.ToJSON PgError where
   toJSON (PgError _ usageError) = JSON.toJSON usageError
@@ -475,11 +476,11 @@ instance PgrstError Error where
   status SingularityError{}      = HTTP.status406
 
   headers (ApiRequestError err)  = headers err
-  headers (JwtTokenInvalid m)    = [MediaType.toContentType MTApplicationJSON, invalidTokenHeader m]
-  headers JwtTokenRequired       = [MediaType.toContentType MTApplicationJSON, requiredTokenHeader]
+  headers (JwtTokenInvalid m)    = [MediaType.toContentType $ MTNormal MTApplicationJSON, invalidTokenHeader m]
+  headers JwtTokenRequired       = [MediaType.toContentType $ MTNormal MTApplicationJSON, requiredTokenHeader]
   headers (PgErr err)            = headers err
-  headers SingularityError{}     = [MediaType.toContentType MTSingularJSON]
-  headers _                      = [MediaType.toContentType MTApplicationJSON]
+  headers SingularityError{}     = [MediaType.toContentType $ MTNormal MTSingularJSON]
+  headers _                      = [MediaType.toContentType $ MTNormal MTApplicationJSON]
 
 instance JSON.ToJSON Error where
   toJSON NoSchemaCacheError = JSON.object [
@@ -530,7 +531,7 @@ instance JSON.ToJSON Error where
   toJSON (SingularityError n) = JSON.object [
     "code"    .= ApiRequestErrorCode16,
     "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),
-    "details" .= T.unwords ["Results contain", show n, "rows,", T.decodeUtf8 (MediaType.toMime MTSingularJSON), "requires 1 row"],
+    "details" .= T.unwords ["Results contain", show n, "rows,", T.decodeUtf8 (MediaType.toMime $ MTNormal MTSingularJSON), "requires 1 row"],
     "hint"    .= JSON.Null]
 
   toJSON (PgErr err) = JSON.toJSON err

src/PostgREST/MediaType.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase            #-}
 
 module PostgREST.MediaType
   ( MediaType(..)
+  , NormalMedia(..)
   , MTPlanOption (..)
   , MTPlanFormat (..)
   , MTPlanAttrs(..)
@@ -13,14 +15,29 @@ module PostgREST.MediaType
 
 import qualified Data.ByteString          as BS
 import qualified Data.ByteString.Internal as BS (c2w)
+import qualified Data.List                as L
 import           Data.Maybe               (fromJust)
 
 import Network.HTTP.Types.Header (Header, hContentType)
 
 import Protolude
+--
+-- $setup
+-- Setup for doctests
+-- >>> import Text.Pretty.Simple (pPrint)
+-- >>> deriving instance Show NormalMedia
+-- >>> deriving instance Show MTPlanFormat
+-- >>> deriving instance Show MTPlanOption
+-- >>> deriving instance Show MTPlanAttrs
+-- >>> deriving instance Show MediaType
 
 -- | Enumeration of currently supported media types
 data MediaType
+  = MTNormal NormalMedia
+  | MTPlan   MTPlanAttrs
+  deriving Eq
+
+data NormalMedia
   = MTApplicationJSON
   | MTSingularJSON
   | MTGeoJSON
@@ -32,83 +49,95 @@ data MediaType
   | MTOctetStream
   | MTAny
   | MTOther ByteString
-  | MTPlan MTPlanAttrs
   deriving Eq
 
-data MTPlanAttrs = MTPlanAttrs (Maybe MediaType) MTPlanFormat [MTPlanOption]
+
+data MTPlanAttrs = MTPlanAttrs (Maybe NormalMedia) MTPlanFormat [MTPlanOption]
 instance Eq MTPlanAttrs where
   MTPlanAttrs {} == MTPlanAttrs {} = True -- we don't care about the attributes when comparing two MTPlan media types
 
 data MTPlanOption
   = PlanAnalyze | PlanVerbose | PlanSettings | PlanBuffers | PlanWAL
+  deriving Eq
 
 data MTPlanFormat
   = PlanJSON | PlanText
+  deriving Eq
 
 -- | Convert MediaType to a Content-Type HTTP Header
 toContentType :: MediaType -> Header
 toContentType ct = (hContentType, toMime ct <> charset)
   where
     charset = case ct of
-      MTOctetStream -> mempty
-      MTOther _     -> mempty
-      _             -> "; charset=utf-8"
+      MTNormal MTOctetStream -> mempty
+      MTNormal (MTOther _)   -> mempty
+      _                      -> "; charset=utf-8"
 
 -- | Convert from MediaType to a ByteString representing the mime type
 toMime :: MediaType -> ByteString
-toMime MTApplicationJSON = "application/json"
-toMime MTGeoJSON         = "application/geo+json"
-toMime MTTextCSV         = "text/csv"
-toMime MTTextPlain       = "text/plain"
-toMime MTTextXML         = "text/xml"
-toMime MTOpenAPI         = "application/openapi+json"
-toMime MTSingularJSON    = "application/vnd.pgrst.object+json"
-toMime MTUrlEncoded      = "application/x-www-form-urlencoded"
-toMime MTOctetStream     = "application/octet-stream"
-toMime MTAny             = "*/*"
-toMime (MTOther ct)      = ct
+toMime (MTNormal x) = toMimeNormal x
 toMime (MTPlan (MTPlanAttrs mt fmt opts)) =
   "application/vnd.pgrst.plan+" <> toMimePlanFormat fmt <>
-  (if isNothing mt then mempty else "; for=\"" <> toMime (fromJust mt) <> "\"") <>
+  (if isNothing mt then mempty else "; for=\"" <> toMimeNormal (fromJust mt) <> "\"") <>
   (if null opts then mempty else "; options=" <> BS.intercalate "|" (toMimePlanOption <$> opts))
 
+toMimeNormal :: NormalMedia -> ByteString
+toMimeNormal = \case
+  MTApplicationJSON -> "application/json"
+  MTGeoJSON         -> "application/geo+json"
+  MTTextCSV         -> "text/csv"
+  MTTextPlain       -> "text/plain"
+  MTTextXML         -> "text/xml"
+  MTOpenAPI         -> "application/openapi+json"
+  MTSingularJSON    -> "application/vnd.pgrst.object+json"
+  MTUrlEncoded      -> "application/x-www-form-urlencoded"
+  MTOctetStream     -> "application/octet-stream"
+  MTAny             -> "*/*"
+  (MTOther ct)      -> ct
+
 toMimePlanOption :: MTPlanOption -> ByteString
-toMimePlanOption PlanAnalyze  = "analyze"
-toMimePlanOption PlanVerbose  = "verbose"
-toMimePlanOption PlanSettings = "settings"
-toMimePlanOption PlanBuffers  = "buffers"
-toMimePlanOption PlanWAL      = "wal"
+toMimePlanOption = \case
+  PlanAnalyze  -> "analyze"
+  PlanVerbose  -> "verbose"
+  PlanSettings -> "settings"
+  PlanBuffers  -> "buffers"
+  PlanWAL      -> "wal"
 
 toMimePlanFormat :: MTPlanFormat -> ByteString
 toMimePlanFormat PlanJSON = "json"
 toMimePlanFormat PlanText = "text"
 
--- | Convert from ByteString to MediaType. Warning: discards MIME parameters
+-- | Convert from ByteString to MediaType.
+--
+-- >>> decodeMediaType "application/json"
+-- MTNormal MTApplicationJSON
+--
+-- >>> decodeMediaType "application/vnd.pgrst.plan;"
+-- MTPlan (MTPlanAttrs Nothing PlanText [])
+--
+-- >>> decodeMediaType "application/vnd.pgrst.plan;for=\"application/json\""
+-- MTPlan (MTPlanAttrs (Just MTApplicationJSON) PlanText [])
+--
+-- >>> decodeMediaType "application/vnd.pgrst.plan;for=\"text/csv\""
+-- MTPlan (MTPlanAttrs (Just MTTextCSV) PlanText [])
+--
+-- A plan media type inside "for" shouldn't recurse
+--
+-- >>> decodeMediaType "application/vnd.pgrst.plan;for=\"application/vnd.pgrst.plan\""
+-- MTPlan (MTPlanAttrs (Just (MTOther "application/vnd.pgrst.plan")) PlanText [])
 decodeMediaType :: BS.ByteString -> MediaType
-decodeMediaType mt =
-  case BS.split (BS.c2w ';') mt of
-    "application/json":_                   -> MTApplicationJSON
-    "application/geo+json":_               -> MTGeoJSON
-    "text/csv":_                           -> MTTextCSV
-    "text/plain":_                         -> MTTextPlain
-    "text/xml":_                           -> MTTextXML
-    "application/openapi+json":_           -> MTOpenAPI
-    "application/vnd.pgrst.object+json":_  -> MTSingularJSON
-    "application/vnd.pgrst.object":_       -> MTSingularJSON
-    "application/x-www-form-urlencoded":_  -> MTUrlEncoded
-    "application/octet-stream":_           -> MTOctetStream
+decodeMediaType bs =
+  case BS.split (BS.c2w ';') bs of
     "application/vnd.pgrst.plan":rest      -> getPlan PlanText rest
     "application/vnd.pgrst.plan+text":rest -> getPlan PlanText rest
     "application/vnd.pgrst.plan+json":rest -> getPlan PlanJSON rest
-    "*/*":_                                -> MTAny
-    other:_                                -> MTOther other
-    _                                      -> MTAny
+    mt                                     -> MTNormal $ decodeNormalMediaType mt
   where
     getPlan fmt rest =
      let
        opts         = BS.split (BS.c2w '|') $ fromMaybe mempty (BS.stripPrefix "options=" =<< find (BS.isPrefixOf "options=") rest)
        inOpts str   = str `elem` opts
-       mtFor        = decodeMediaType . dropAround (== BS.c2w '"') <$> (BS.stripPrefix "for=" =<< find (BS.isPrefixOf "for=") rest)
+       mtFor        = decodeNormalMediaType . L.singleton . dropAround (== BS.c2w '"') <$> (BS.stripPrefix "for=" =<< find (BS.isPrefixOf "for=") rest)
        dropAround p = BS.dropWhile p . BS.dropWhileEnd p in
      MTPlan $ MTPlanAttrs mtFor fmt $
       [PlanAnalyze  | inOpts "analyze" ] ++
@@ -117,8 +146,26 @@ decodeMediaType mt =
       [PlanBuffers  | inOpts "buffers" ] ++
       [PlanWAL      | inOpts "wal"     ]
 
-getMediaType :: MediaType -> MediaType
+-- | Convert from ByteString to MediaType. Warning: discards MIME parameters
+decodeNormalMediaType :: [BS.ByteString] -> NormalMedia
+decodeNormalMediaType bs =
+  case bs of
+    "application/json":_                  -> MTApplicationJSON
+    "application/geo+json":_              -> MTGeoJSON
+    "text/csv":_                          -> MTTextCSV
+    "text/plain":_                        -> MTTextPlain
+    "text/xml":_                          -> MTTextXML
+    "application/openapi+json":_          -> MTOpenAPI
+    "application/vnd.pgrst.object+json":_ -> MTSingularJSON
+    "application/vnd.pgrst.object":_      -> MTSingularJSON
+    "application/x-www-form-urlencoded":_ -> MTUrlEncoded
+    "application/octet-stream":_          -> MTOctetStream
+    "*/*":_                               -> MTAny
+    other:_                               -> MTOther other
+    _                                     -> MTAny
+
+getMediaType :: MediaType -> NormalMedia
 getMediaType mt = case mt of
   MTPlan (MTPlanAttrs (Just mType) _ _) -> mType
   MTPlan (MTPlanAttrs Nothing _ _)      -> MTApplicationJSON
-  other                                 -> other
+  MTNormal x                            -> x