Skip to content

Commit

Permalink
refactor: plan media type
Browse files Browse the repository at this point in the history
  • Loading branch information
@steve-chavez
steve-chavez committed Jun 18, 2023
1 parent 78821a8 commit 3cd3a3f
Show file tree
Hide file tree
Showing 11 changed files with 157 additions and 100 deletions.
35 changes: 18 additions & 17 deletions src/PostgREST/ApiRequest.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,7 +53,8 @@ import PostgREST.Config (AppConfig (..),
OpenAPIMode (..))
import PostgREST.MediaType (MTPlanAttrs (..),
MTPlanFormat (..),
MediaType (..))
MediaType (..),
NormalMedia (..))
import PostgREST.RangeQuery (NonnegRange, allRange,
convertToLimitZeroRange,
hasLimitZero,
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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]
5 changes: 3 additions & 2 deletions src/PostgREST/Config.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down Expand Up @@ -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")
Expand Down
33 changes: 17 additions & 16 deletions src/PostgREST/Error.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..),
Expand Down Expand Up @@ -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 [
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 [
Expand Down Expand Up @@ -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
Expand Down
129 changes: 88 additions & 41 deletions src/PostgREST/MediaType.hs
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,9 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}

module PostgREST.MediaType
( MediaType(..)
, NormalMedia(..)
, MTPlanOption (..)
, MTPlanFormat (..)
, MTPlanAttrs(..)
Expand All @@ -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
Expand All @@ -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" ] ++
Expand All @@ -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
Loading

0 comments on commit 3cd3a3f

Please sign in to comment.