Wolfgang Walther
aa7d442d32
src/ now contains all source code - in subdirectories, according to the .cabal component they belong to. This will allow us to put vendored libraries in the same place - and later split our own code into multiple components/libraries as well.
83 lines
4.6 KiB
Haskell
83 lines
4.6 KiB
Haskell
{-|
|
|
Module : PostgREST.Plan.Negotiate
|
|
Description : PostgREST Content Negotiation
|
|
|
|
This module contains logic for content negotiation.
|
|
RFC: https://datatracker.ietf.org/doc/html/rfc7231#section-3.4
|
|
-}
|
|
|
|
module PostgREST.Plan.Negotiate
|
|
( negotiateContent
|
|
) where
|
|
|
|
import qualified Data.HashMap.Strict as HM
|
|
|
|
import PostgREST.ApiRequest (ApiRequest (..))
|
|
import PostgREST.Config (AppConfig (..))
|
|
import PostgREST.Error (ApiRequestError (..))
|
|
import PostgREST.MediaType (MediaType (..))
|
|
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
|
|
RelIdentifier (..))
|
|
import PostgREST.SchemaCache.Routine (MediaHandler (..),
|
|
MediaHandlerMap,
|
|
ResolvedHandler)
|
|
|
|
import PostgREST.ApiRequest.Preferences
|
|
import PostgREST.ApiRequest.Types
|
|
import qualified PostgREST.MediaType as MediaType
|
|
|
|
import Protolude hiding (from)
|
|
|
|
-- We have two general cases of return values from database objects
|
|
-- (tables/views/functions):
|
|
--
|
|
-- 1. "un-mime-typed" values, in most of the cases this is a composite/row
|
|
-- value, for example for tables or views, but also often for functions.
|
|
-- It can be simple integer values or text or bytea as well.
|
|
--
|
|
-- For this, we need handlers to transform the "non-mime-typed" values
|
|
-- into "mimetypes". We have a default builtin handler that does
|
|
-- "application/json". We can add more handlers via aggregates.
|
|
--
|
|
-- 2. "mime-typed" values, which specifically return a domain type that is
|
|
-- associated to a certain mimetype. e.g, a function returning only
|
|
-- "image/png".
|
|
--
|
|
-- FIXME:
|
|
-- If the function returns a domain type - let's say image/png, we should
|
|
-- accept */*, image/*, and image/png.
|
|
-- Related issue: https://github.com/PostgREST/postgrest/issues/3391
|
|
|
|
-- | Do content negotiation. i.e. choose a media type based on the
|
|
-- intersection of accepted/produced media types.
|
|
negotiateContent :: AppConfig -> ApiRequest -> QualifiedIdentifier -> [MediaType] -> MediaHandlerMap -> Bool -> Either ApiRequestError ResolvedHandler
|
|
negotiateContent conf ApiRequest{iAction=act, iPreferences=Preferences{preferRepresentation=rep}} identifier accepts produces defaultSelect =
|
|
case (act, firstAcceptedPick) of
|
|
(_, Nothing) -> Left . MediaTypeError $ map MediaType.toMime accepts
|
|
(ActDb (ActRelationMut _ _), 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.
|
|
(ActDb (ActRelationRead _ True), Just (_, mt)) -> Right (NoAgg, mt)
|
|
(ActDb (ActRoutine _ (InvRead True)), Just (_, mt)) -> Right (NoAgg, mt)
|
|
(_, Just (x, mt)) -> Right (x, mt)
|
|
where
|
|
firstAcceptedPick = listToMaybe $ mapMaybe matchMT accepts -- If there are multiple accepted media types, pick the first. This is usual in content negotiation.
|
|
matchMT mt = case mt of
|
|
-- 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)
|
|
-- TODO the plan should have its own MediaHandler instead of relying on MediaType
|
|
m@(MTVndPlan mType _ _) -> mtPlanToNothing $ ((,) . fst <$> lookupHandler mType) <*> pure m
|
|
-- all the other media types can be overridden
|
|
x -> lookupHandler x
|
|
mtPlanToNothing x = if configDbPlanEnabled conf then x else Nothing -- don't find anything if the plan media type is not allowed
|
|
lookupHandler mt =
|
|
when' defaultSelect (HM.lookup (RelId identifier, MTAny) produces) <|> -- lookup for identifier and `*/*`
|
|
when' defaultSelect (HM.lookup (RelId identifier, mt) produces) <|> -- lookup for identifier and a particular media type
|
|
HM.lookup (RelAnyElement, mt) produces -- lookup for anyelement and a particular media type
|
|
when' :: Bool -> Maybe a -> Maybe a
|
|
when' True (Just a) = Just a
|
|
when' _ _ = Nothing
|