refactor: getSchema in ApiRequest

src/PostgREST/App.hs

@@ -285,7 +285,7 @@ handleInvoke invMethod proc context@RequestContext{..} = do
 handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response
 handleOpenApi headersOnly tSchema (RequestContext conf dbStructure apiRequest pgVer) = do
   oaiResult <- Query.openApiQuery dbStructure pgVer conf tSchema
-  pure $ Response.openApiResponse headersOnly oaiResult conf dbStructure $ iProfile apiRequest
+  pure $ Response.openApiResponse headersOnly oaiResult conf dbStructure (iSchema apiRequest) (iNegotiatedByProfile apiRequest)
 
 writeRequest :: Mutation -> QualifiedIdentifier -> RequestContext -> [FieldName] -> Either Error (MutateRequest.MutateRequest, ReadRequest)
 writeRequest mutation identifier@QualifiedIdentifier{..} context@RequestContext{..} pkCols = do

src/PostgREST/Request/ApiRequest.hs

@@ -35,7 +35,6 @@ import qualified Data.Vector           as V
 import Control.Arrow             ((***))
 import Data.Aeson.Types          (emptyArray, emptyObject)
 import Data.List                 (lookup, union)
-import Data.Maybe                (fromJust)
 import Data.Ranged.Ranges        (emptyRange, rangeIntersection,
                                   rangeIsEmpty)
 import Network.HTTP.Types.Header (hCookie, RequestHeaders)
@@ -171,8 +170,8 @@ data ApiRequest = ApiRequest {
   , iCookies              :: [(ByteString, ByteString)]       -- ^ Request Cookies
   , iPath                 :: ByteString                       -- ^ Raw request path
   , iMethod               :: ByteString                       -- ^ Raw request method
-  , iProfile              :: Maybe Schema                     -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/.
+  , iSchema               :: Schema                           -- ^ The request schema. Can vary depending on profile headers.
-  , iSchema               :: Schema                           -- ^ The request schema. Can vary depending on iProfile.
+  , iNegotiatedByProfile  :: Bool                             -- ^ If schema was was chosen according to the profile spec https://www.w3.org/TR/dx-prof-conneg/
   , iAcceptMediaType      :: MediaType
   }
 
@@ -183,7 +182,8 @@ userApiRequest conf dbStructure req reqBody = do
   pInfo <- getPathInfo conf $ pathInfo req
   act <- getAction pInfo $ requestMethod req
   mediaTypes <- getMediaTypes conf (requestHeaders req) act pInfo
-  apiRequest conf dbStructure req reqBody qPrms pInfo act mediaTypes
+  negotiatedSchema <- getSchema conf (requestHeaders req) (requestMethod req)
+  apiRequest dbStructure req reqBody qPrms pInfo act mediaTypes negotiatedSchema
 
 getPathInfo :: AppConfig -> [Text] -> Either ApiRequestError PathInfo
 getPathInfo AppConfig{configOpenApiMode, configDbRootSpec} path =
@@ -226,9 +226,27 @@ getMediaTypes conf hdrs action path = do
     contentMediaType = maybe MTApplicationJSON MediaType.decodeMediaType $ lookupHeader "content-type"
     lookupHeader    = flip lookup hdrs
 
-apiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> QueryParams.QueryParams -> PathInfo -> Action -> (MediaType, MediaType) -> Either ApiRequestError ApiRequest
+getSchema :: AppConfig -> RequestHeaders -> ByteString -> Either ApiRequestError (Schema, Bool)
-apiRequest AppConfig{configDbSchemas} dbStructure req reqBody queryparams@QueryParams{..} PathInfo{pathName, pathIsProc, pathIsRootSpec, pathIsDefSpec} action (acceptMediaType, contentMediaType)
+getSchema AppConfig{configDbSchemas} hdrs method = do
-  | isJust profile && fromJust profile `notElem` configDbSchemas = Left $ UnacceptableSchema $ toList configDbSchemas
+  case profile of
+    Just p | p `notElem` configDbSchemas -> Left $ UnacceptableSchema $ toList configDbSchemas
+           | otherwise                   -> Right (p, True)
+    Nothing -> Right (defaultSchema, length configDbSchemas /= 1) -- if we have many schemas, assume the default schema was negotiated
+  where
+    defaultSchema = NonEmptyList.head configDbSchemas
+    profile = case method of
+      -- POST/PATCH/PUT/DELETE don't use the same header as per the spec
+      "DELETE" -> contentProfile
+      "PATCH"  -> contentProfile
+      "POST"   -> contentProfile
+      "PUT"    -> contentProfile
+      _        -> acceptProfile
+    contentProfile = T.decodeUtf8 <$> lookupHeader "Content-Profile"
+    acceptProfile = T.decodeUtf8 <$> lookupHeader "Accept-Profile"
+    lookupHeader    = flip lookup hdrs
+
+apiRequest :: DbStructure -> Request -> RequestBody -> QueryParams.QueryParams -> PathInfo -> Action -> (MediaType, MediaType) -> (Schema, Bool) -> Either ApiRequestError ApiRequest
+apiRequest dbStructure req reqBody queryparams@QueryParams{..} PathInfo{pathName, pathIsProc, pathIsRootSpec, pathIsDefSpec} action (acceptMediaType, contentMediaType) (schema, negotiatedByProfile)
   | isInvalidRange = Left $ InvalidRange (if rangeIsEmpty headerRange then LowerGTUpper else NegativeLimit)
   | shouldParsePayload && isLeft payload = either (Left . InvalidBody) witness payload
   | not expectParams && not (L.null qsParams) = Left $ ParseRequestError "Unexpected param or filter missing operator" ("Failed to parse " <> show qsParams)
@@ -253,8 +271,8 @@ apiRequest AppConfig{configDbSchemas} dbStructure req reqBody queryparams@QueryP
       , iCookies = maybe [] parseCookies $ lookupHeader "Cookie"
       , iPath = rawPathInfo req
       , iMethod = method
-      , iProfile = profile
       , iSchema = schema
+      , iNegotiatedByProfile = negotiatedByProfile
       , iAcceptMediaType = acceptMediaType
       }
  where
@@ -296,23 +314,6 @@ apiRequest AppConfig{configDbSchemas} dbStructure req reqBody queryparams@QueryP
     (ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
   topLevelRange = fromMaybe allRange $ HM.lookup "limit" ranges -- if no limit is specified, get all the request rows
 
-  defaultSchema = NonEmptyList.head configDbSchemas
-  profile
-    | length configDbSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config
-      = Nothing
-    | otherwise = case method of
-        -- POST/PATCH/PUT/DELETE don't use the same header as per the spec
-        "DELETE" -> contentProfile
-        "PATCH"  -> contentProfile
-        "POST"   -> contentProfile
-        "PUT"    -> contentProfile
-        _        -> acceptProfile
-    where
-      contentProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Content-Profile"
-      acceptProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Accept-Profile"
-
-  schema = fromMaybe defaultSchema profile
-
   target
     | pathIsProc    = (`TargetProc` pathIsRootSpec) <$> callFindProc schema pathName
     | pathIsDefSpec = Right $ TargetDefaultSpec schema

src/PostgREST/Response.hs

@@ -215,10 +215,10 @@ invokeResponse invMethod proc ctxApiRequest@ApiRequest{..} resultSet = case resu
   RSPlan plan ->
     Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
 
-openApiResponse :: Bool -> Maybe (TablesMap, ProcsMap, Maybe Text) -> AppConfig -> DbStructure -> Maybe Schema -> Wai.Response
+openApiResponse :: Bool -> Maybe (TablesMap, ProcsMap, Maybe Text) -> AppConfig -> DbStructure -> Schema -> Bool -> Wai.Response
-openApiResponse headersOnly body conf dbStructure iProfile =
+openApiResponse headersOnly body conf dbStructure schema negotiatedByProfile =
   Wai.responseLBS HTTP.status200
-    (MediaType.toContentType MTOpenAPI : maybeToList (profileHeader iProfile))
+    (MediaType.toContentType MTOpenAPI : maybeToList (profileHeader schema negotiatedByProfile))
     (maybe mempty (\(x, y, z) -> if headersOnly then mempty else OpenAPI.encode conf dbStructure x y z) body)
 
 -- | Response with headers and status overridden from GUCs.
@@ -245,11 +245,14 @@ decodeGucStatus =
 
 contentTypeHeaders :: ApiRequest -> [HTTP.Header]
 contentTypeHeaders ApiRequest{..} =
-  MediaType.toContentType iAcceptMediaType : maybeToList (profileHeader iProfile)
+  MediaType.toContentType iAcceptMediaType : maybeToList (profileHeader iSchema iNegotiatedByProfile)
 
-profileHeader :: Maybe Schema -> Maybe HTTP.Header
+profileHeader :: Schema -> Bool -> Maybe HTTP.Header
-profileHeader iProfile =
+profileHeader schema negotiatedByProfile =
-  (,) "Content-Profile" <$> (toS <$> iProfile)
+  if negotiatedByProfile
+    then Just $ (,) "Content-Profile" (toS schema)
+  else
+    Nothing
 
 addRetryHint :: Int -> Wai.Response -> Wai.Response
 addRetryHint delay response = do