refactor: make Response module pure

src/PostgREST/App.hs

@@ -172,47 +172,57 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
     (ActionRead headersOnly, TargetIdent identifier) -> do
       wrPlan <- liftEither $ Plan.wrappedReadPlan identifier conf sCache apiReq
       resultSet <- runQuery roleIsoLvl (Plan.wrTxMode wrPlan) $ Query.readQuery wrPlan conf apiReq
-      return $ Response.readResponse wrPlan headersOnly identifier apiReq resultSet serverTimingParams
+      pgrst <- liftEither $ Response.readResponse wrPlan headersOnly identifier apiReq resultSet serverTimingParams
+      return $ pgrstResponse pgrst
 
     (ActionMutate MutationCreate, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationCreate apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.createQuery mrPlan apiReq conf
-      return $ Response.createResponse identifier mrPlan apiReq resultSet serverTimingParams
+      pgrst <- liftEither $ Response.createResponse identifier mrPlan apiReq resultSet serverTimingParams
+      return $ pgrstResponse pgrst
 
     (ActionMutate MutationUpdate, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationUpdate apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.updateQuery mrPlan apiReq conf
-      return $ Response.updateResponse mrPlan apiReq resultSet serverTimingParams
+      pgrst <- liftEither $ Response.updateResponse mrPlan apiReq resultSet serverTimingParams
+      return $ pgrstResponse pgrst
 
     (ActionMutate MutationSingleUpsert, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationSingleUpsert apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.singleUpsertQuery mrPlan apiReq conf
-      return $ Response.singleUpsertResponse mrPlan apiReq resultSet serverTimingParams
+      pgrst <- liftEither $ Response.singleUpsertResponse mrPlan apiReq resultSet serverTimingParams
+      return $ pgrstResponse pgrst
 
     (ActionMutate MutationDelete, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationDelete apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.deleteQuery mrPlan apiReq conf
-      return $ Response.deleteResponse mrPlan apiReq resultSet serverTimingParams
+      pgrst <- liftEither $ Response.deleteResponse mrPlan apiReq resultSet serverTimingParams
+      return $ pgrstResponse pgrst
 
     (ActionInvoke invMethod, TargetProc identifier _) -> do
       cPlan <- liftEither $ Plan.callReadPlan identifier conf sCache apiReq invMethod
       resultSet <- runQuery (fromMaybe roleIsoLvl $ pdIsoLvl (Plan.crProc cPlan))(Plan.crTxMode cPlan) $ Query.invokeQuery (Plan.crProc cPlan) cPlan apiReq conf pgVer
-      return $ Response.invokeResponse cPlan invMethod (Plan.crProc cPlan) apiReq resultSet serverTimingParams
+      pgrst <- liftEither $ Response.invokeResponse cPlan invMethod (Plan.crProc cPlan) apiReq resultSet serverTimingParams
+      return $ pgrstResponse pgrst
 
     (ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
       iPlan <- liftEither $ Plan.inspectPlan conf apiReq
       oaiResult <- runQuery roleIsoLvl (Plan.ipTxmode iPlan) $ Query.openApiQuery sCache pgVer conf tSchema
-      return $ Response.openApiResponse (T.decodeUtf8 prettyVersion, docsVersion) headersOnly oaiResult conf sCache iSchema iNegotiatedByProfile
+      pgrst <- liftEither $ Response.openApiResponse (T.decodeUtf8 prettyVersion, docsVersion) headersOnly oaiResult conf sCache iSchema iNegotiatedByProfile
+      return $ pgrstResponse pgrst
 
-    (ActionInfo, TargetIdent identifier) ->
+    (ActionInfo, TargetIdent identifier) -> do
-      return $ Response.infoIdentResponse identifier sCache
+      pgrst <- liftEither $ Response.infoIdentResponse identifier sCache
+      return $ pgrstResponse pgrst
 
     (ActionInfo, TargetProc identifier _) -> do
       cPlan <- liftEither $ Plan.callReadPlan identifier conf sCache apiReq ApiRequest.InvHead
-      return $ Response.infoProcResponse (Plan.crProc cPlan)
+      pgrst <- liftEither $ Response.infoProcResponse (Plan.crProc cPlan)
+      return $ pgrstResponse pgrst
 
-    (ActionInfo, TargetDefaultSpec _) ->
+    (ActionInfo, TargetDefaultSpec _) -> do
-      return Response.infoRootResponse
+      pgrst <- liftEither Response.infoRootResponse
+      return $ pgrstResponse pgrst
 
     _ ->
       -- This is unreachable as the ApiRequest.hs rejects it before
@@ -226,3 +236,6 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
         Query.setPgLocals conf authClaims authRole (HM.toList roleSettings) apiReq pgVer
         Query.runPreReq conf
         query
+
+    pgrstResponse :: Response.PgrstResponse -> Wai.Response
+    pgrstResponse (Response.PgrstResponse st hdrs bod) = Wai.responseLBS st hdrs bod

src/PostgREST/Query.hs

@@ -206,7 +206,7 @@ writeQuery MutateReadPlan{mrReadPlan, mrMutatePlan, mrResAgg, mrMedia} ApiReques
 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 [MTSingularJSON True,MTSingularJSON False] && queryTotal /= 1) $ do
     lift SQL.condemn
     throwError $ Error.singularityError queryTotal
 

src/PostgREST/Response.hs

@@ -19,6 +19,7 @@ module PostgREST.Response
   , isServiceUnavailable
   , traceHeaderMiddleware
   , ServerTimingParams(..)
+  , PgrstResponse(..)
   ) where
 
 import qualified Data.Aeson                as JSON
@@ -73,13 +74,18 @@ newtype ServerTimingParams = ServerTimingParams {
   jwtDur :: Double
 }
 
-readResponse :: WrappedReadPlan -> Bool -> QualifiedIdentifier -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+data PgrstResponse = PgrstResponse {
+  pgrstStatus  :: HTTP.Status
+, pgrstHeaders :: [HTTP.Header]
+, pgrstBody    :: LBS.ByteString
+}
+
+readResponse :: WrappedReadPlan -> Bool -> QualifiedIdentifier -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Either Error.Error PgrstResponse
 readResponse WrappedReadPlan{wrMedia} headersOnly identifier ctxApiRequest@ApiRequest{iPreferences=Preferences{..},..} resultSet serverTimingParams =
   case resultSet of
     RSStandard{..} -> do
       let
         (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
-        response = gucResponse rsGucStatus rsGucHeaders
         prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing Nothing Nothing preferCount preferTransaction Nothing
         headers =
           [ contentRange
@@ -92,22 +98,24 @@ readResponse WrappedReadPlan{wrMedia} headersOnly identifier ctxApiRequest@ApiRe
           ++ contentTypeHeaders wrMedia ctxApiRequest
           ++ prefHeader
           ++ serverTimingHeader serverTimingParams
-        rsOrErrBody = if status == HTTP.status416
-          then Error.errorPayload $ Error.ApiRequestError $ ApiRequestTypes.InvalidRange
-            $ ApiRequestTypes.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
-          else LBS.fromStrict rsBody
 
-      response status headers $ if headersOnly then mempty else rsOrErrBody
+      (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers
+
+      let bod | status == HTTP.status416 = Error.errorPayload $ Error.ApiRequestError $ ApiRequestTypes.InvalidRange $
+                                           ApiRequestTypes.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
+              | headersOnly              = mempty
+              | otherwise                = LBS.fromStrict rsBody
+
+      Right $ PgrstResponse ovStatus ovHeaders bod
 
     RSPlan plan ->
-      Wai.responseLBS HTTP.status200 (contentTypeHeaders wrMedia ctxApiRequest) $ LBS.fromStrict plan
+      Right $ PgrstResponse HTTP.status200 (contentTypeHeaders wrMedia ctxApiRequest) $ LBS.fromStrict plan
 
-createResponse :: QualifiedIdentifier -> MutateReadPlan -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+createResponse :: QualifiedIdentifier -> MutateReadPlan -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Either Error.Error PgrstResponse
 createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan, mrMedia} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}, ..} resultSet serverTimingParams = case resultSet of
   RSStandard{..} -> do
     let
       pkCols = case mrMutatePlan of { Insert{insPkCols} -> insPkCols; _ -> mempty;}
-      response = gucResponse rsGucStatus rsGucHeaders
       prefHeader = prefAppliedHeader $
         Preferences (if null pkCols && isNothing (qsOnConflict iQueryParams) then Nothing else preferResolution)
         preferRepresentation Nothing preferCount preferTransaction preferMissing
@@ -127,75 +135,90 @@ createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan, mrMedia} ctx
           , prefHeader
           ] ++ serverTimingHeader serverTimingParams
 
-    case preferRepresentation of
+    let status = HTTP.status201
-      Just Full -> response HTTP.status201 (headers ++ contentTypeHeaders mrMedia ctxApiRequest) (LBS.fromStrict rsBody)
+    let (headers', bod) = case preferRepresentation of
-      Just None -> response HTTP.status201 headers mempty
+          Just Full -> (headers ++ contentTypeHeaders mrMedia ctxApiRequest, LBS.fromStrict rsBody)
-      Just HeadersOnly -> response HTTP.status201 headers mempty
+          Just None -> (headers, mempty)
-      Nothing -> response HTTP.status201 headers mempty
+          Just HeadersOnly -> (headers, mempty)
+          Nothing -> (headers, mempty)
 
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'
+
+    Right $ PgrstResponse ovStatus ovHeaders bod
   RSPlan plan ->
-    Wai.responseLBS HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
 
-updateResponse :: MutateReadPlan -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+updateResponse :: MutateReadPlan -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Either Error.Error PgrstResponse
 updateResponse MutateReadPlan{mrMedia} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet serverTimingParams = case resultSet of
   RSStandard{..} -> do
     let
-      response = gucResponse rsGucStatus rsGucHeaders
       contentRangeHeader =
         Just . RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
           if shouldCount preferCount then Just rsQueryTotal else Nothing
       prefHeader = prefAppliedHeader $ Preferences Nothing preferRepresentation Nothing preferCount preferTransaction preferMissing
       headers = catMaybes [contentRangeHeader, prefHeader] ++ serverTimingHeader serverTimingParams
 
-    case preferRepresentation of
+    let
-        Just Full -> response HTTP.status200 (headers ++ contentTypeHeaders mrMedia ctxApiRequest) (LBS.fromStrict rsBody)
+      (status, headers', body) = case preferRepresentation of
-        Just None -> response HTTP.status204 headers mempty
+                          Just Full -> (HTTP.status200, headers ++ contentTypeHeaders mrMedia ctxApiRequest, LBS.fromStrict rsBody)
-        _ -> response HTTP.status204 headers mempty
+                          Just None -> (HTTP.status204, headers, mempty)
+                          _ -> (HTTP.status204, headers, mempty)
+
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'
+
+    Right $ PgrstResponse ovStatus ovHeaders body
 
   RSPlan plan ->
-    Wai.responseLBS HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
 
-singleUpsertResponse :: MutateReadPlan -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+singleUpsertResponse :: MutateReadPlan -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Either Error.Error PgrstResponse
 singleUpsertResponse MutateReadPlan{mrMedia} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet serverTimingParams = case resultSet of
   RSStandard {..} -> do
     let
-      response = gucResponse rsGucStatus rsGucHeaders
       prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing preferRepresentation Nothing preferCount preferTransaction Nothing
       sTHeader = serverTimingHeader serverTimingParams
       cTHeader = contentTypeHeaders mrMedia ctxApiRequest
 
-    case preferRepresentation of
+    let (status, headers, body) =
-      Just Full -> response HTTP.status200 (cTHeader ++ sTHeader ++ prefHeader) (LBS.fromStrict rsBody)
+          case preferRepresentation of
-      Just None -> response HTTP.status204 (sTHeader ++ prefHeader) mempty
+            Just Full -> (HTTP.status200, cTHeader ++ sTHeader ++ prefHeader, LBS.fromStrict rsBody)
-      _ -> response HTTP.status204 (sTHeader ++ prefHeader) mempty
+            Just None -> (HTTP.status204,  sTHeader ++ prefHeader, mempty)
+            _ -> (HTTP.status204, sTHeader ++ prefHeader, mempty)
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers
+
+    Right $ PgrstResponse ovStatus ovHeaders body
 
   RSPlan plan ->
-    Wai.responseLBS HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
 
-deleteResponse :: MutateReadPlan -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+deleteResponse :: MutateReadPlan -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Either Error.Error PgrstResponse
 deleteResponse MutateReadPlan{mrMedia} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet serverTimingParams = case resultSet of
   RSStandard {..} -> do
     let
-      response = gucResponse rsGucStatus rsGucHeaders
       contentRangeHeader =
         RangeQuery.contentRangeH 1 0 $
           if shouldCount preferCount then Just rsQueryTotal else Nothing
       prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing preferRepresentation Nothing preferCount preferTransaction Nothing
       headers = contentRangeHeader : prefHeader ++ serverTimingHeader serverTimingParams
 
-    case preferRepresentation of
+    let (status, headers', body) =
-        Just Full -> response HTTP.status200 (headers ++ contentTypeHeaders mrMedia ctxApiRequest) (LBS.fromStrict rsBody)
+          case preferRepresentation of
-        Just None -> response HTTP.status204 headers mempty
+              Just Full -> (HTTP.status200, headers ++ contentTypeHeaders mrMedia ctxApiRequest, LBS.fromStrict rsBody)
-        _ -> response HTTP.status204 headers mempty
+              Just None -> (HTTP.status204, headers, mempty)
+              _ -> (HTTP.status204, headers, mempty)
+
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'
+
+    Right $ PgrstResponse ovStatus ovHeaders body
 
   RSPlan plan ->
-    Wai.responseLBS HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
 
-infoIdentResponse :: QualifiedIdentifier -> SchemaCache -> Wai.Response
+infoIdentResponse :: QualifiedIdentifier -> SchemaCache -> Either Error.Error PgrstResponse
-infoIdentResponse identifier sCache =
+infoIdentResponse identifier sCache = do
   case HM.lookup identifier (dbTables sCache) of
     Just tbl -> respondInfo $ allowH tbl
-    Nothing  -> Error.errorResponseFor $ Error.ApiRequestError ApiRequestTypes.NotFound
+    Nothing  -> Left $ Error.ApiRequestError ApiRequestTypes.NotFound
   where
     allowH table =
       let hasPK = not . null $ tablePKCols table in
@@ -206,23 +229,22 @@ infoIdentResponse identifier sCache =
           ["PATCH" | tableUpdatable table] ++
           ["DELETE" | tableDeletable table]
 
-infoProcResponse :: Routine -> Wai.Response
+infoProcResponse :: Routine -> Either Error.Error PgrstResponse
 infoProcResponse proc | pdVolatility proc == Volatile = respondInfo "OPTIONS,POST"
                       | otherwise                     = respondInfo "OPTIONS,GET,HEAD,POST"
 
-infoRootResponse :: Wai.Response
+infoRootResponse :: Either Error.Error PgrstResponse
 infoRootResponse = respondInfo "OPTIONS,GET,HEAD"
 
-respondInfo :: ByteString -> Wai.Response
+respondInfo :: ByteString -> Either Error.Error PgrstResponse
 respondInfo allowHeader =
   let allOrigins = ("Access-Control-Allow-Origin", "*") in
-  Wai.responseLBS HTTP.status200 [allOrigins, (HTTP.hAllow, allowHeader)] mempty
+  Right $ PgrstResponse HTTP.status200 [allOrigins, (HTTP.hAllow, allowHeader)] mempty
 
-invokeResponse :: CallReadPlan -> InvokeMethod -> Routine -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+invokeResponse :: CallReadPlan -> InvokeMethod -> Routine -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Either Error.Error PgrstResponse
 invokeResponse CallReadPlan{crMedia} invMethod proc ctxApiRequest@ApiRequest{iPreferences=Preferences{..},..} resultSet serverTimingParams = case resultSet of
   RSStandard {..} -> do
     let
-      response = gucResponse rsGucStatus rsGucHeaders
       (status, contentRange) =
         RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
       rsOrErrBody = if status == HTTP.status416
@@ -232,35 +254,33 @@ invokeResponse CallReadPlan{crMedia} invMethod proc ctxApiRequest@ApiRequest{iPr
       prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing Nothing preferParameters preferCount preferTransaction Nothing
       headers = contentRange : prefHeader ++ serverTimingHeader serverTimingParams
 
-    if Routine.funcReturnsVoid proc then
+    let (status', headers', body) =
-        response HTTP.status204 headers mempty
+          if Routine.funcReturnsVoid proc then
-      else
+              (HTTP.status204, headers, mempty)
-        response status
+            else
-          (headers ++ contentTypeHeaders crMedia ctxApiRequest)
+              (status,
-          (if invMethod == InvHead then mempty else rsOrErrBody)
+                headers ++ contentTypeHeaders crMedia ctxApiRequest,
+                if invMethod == InvHead then mempty else rsOrErrBody)
+
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status' headers'
+
+    Right $ PgrstResponse ovStatus ovHeaders body
 
   RSPlan plan ->
-    Wai.responseLBS HTTP.status200 (contentTypeHeaders crMedia ctxApiRequest) $ LBS.fromStrict plan
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders crMedia ctxApiRequest) $ LBS.fromStrict plan
 
-openApiResponse :: (Text, Text) -> Bool -> Maybe (TablesMap, RoutineMap, Maybe Text) -> AppConfig -> SchemaCache -> Schema -> Bool -> Wai.Response
+openApiResponse :: (Text, Text) -> Bool -> Maybe (TablesMap, RoutineMap, Maybe Text) -> AppConfig -> SchemaCache -> Schema -> Bool -> Either Error.Error PgrstResponse
 openApiResponse versions headersOnly body conf sCache schema negotiatedByProfile =
-  Wai.responseLBS HTTP.status200
+  Right $ PgrstResponse HTTP.status200
     (MediaType.toContentType MTOpenAPI : maybeToList (profileHeader schema negotiatedByProfile))
     (maybe mempty (\(x, y, z) -> if headersOnly then mempty else OpenAPI.encode versions conf sCache x y z) body)
 
--- | Response with headers and status overridden from GUCs.
+-- Status and headers can be overridden as per https://postgrest.org/en/stable/references/transactions.html#response-headers
-gucResponse
+overrideStatusHeaders :: Maybe Text -> Maybe BS.ByteString -> HTTP.Status -> [HTTP.Header]-> Either Error.Error (HTTP.Status, [HTTP.Header])
-  :: Maybe Text
+overrideStatusHeaders rsGucStatus rsGucHeaders pgrstStatus pgrstHeaders = do
-  -> Maybe BS.ByteString
+  gucStatus <- decodeGucStatus rsGucStatus
-  -> HTTP.Status
+  gucHeaders <- decodeGucHeaders rsGucHeaders
-  -> [HTTP.Header]
+  Right (fromMaybe pgrstStatus gucStatus, addHeadersIfNotIncluded pgrstHeaders $ map unwrapGucHeader gucHeaders)
-  -> LBS.ByteString
-  -> Wai.Response
-gucResponse rsGucStatus rsGucHeaders status headers body =
-  case (,) <$> decodeGucStatus rsGucStatus <*> decodeGucHeaders rsGucHeaders of
-    Left err -> Error.errorResponseFor err
-    Right (gucStatus, gucHeaders) ->
-      Wai.responseLBS (fromMaybe status gucStatus) (addHeadersIfNotIncluded headers (map unwrapGucHeader gucHeaders)) body
 
 decodeGucHeaders :: Maybe BS.ByteString -> Either Error.Error [GucHeader]
 decodeGucHeaders =