refactor: add Response.hs module

* add response updateResponse
* add singleUpsertResponse
* add delete/invoke response
* add open api response
* add info response
* remove ApiRequest from profileHeader
* contentTypeHeaders only needs ApiRequest

postgrest.cabal

@@ -67,6 +67,7 @@ library
                       PostgREST.Request.QueryParams
                       PostgREST.Request.ReadQuery
                       PostgREST.Request.Types
+                      PostgREST.Response
                       PostgREST.Version
                       PostgREST.Workers
   other-modules:      Paths_postgrest

src/PostgREST/App.hs

@@ -18,9 +18,6 @@ module PostgREST.App
   ) where
 
 
-import Data.Text.Read            (decimal)
-import Network.HTTP.Types.Status (Status)
-
 import Control.Monad.Except     (liftEither)
 import Data.Either.Combinators  (mapLeft)
 import Data.List                (union)
@@ -30,17 +27,10 @@ import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
                                  setServerName)
 import System.Posix.Types       (FileMode)
 
-import qualified Data.Aeson                      as JSON
-import qualified Data.ByteString.Char8           as BS
-import qualified Data.ByteString.Lazy            as LBS
 import qualified Data.HashMap.Strict             as HM
-import qualified Data.Set                        as S
 import qualified Hasql.DynamicStatements.Snippet as SQL (Snippet)
 import qualified Hasql.Transaction               as SQL
 import qualified Hasql.Transaction.Sessions      as SQL
-import qualified Network.HTTP.Types.Header       as HTTP
-import qualified Network.HTTP.Types.Status       as HTTP
-import qualified Network.HTTP.Types.URI          as HTTP
 import qualified Network.Wai                     as Wai
 import qualified Network.Wai.Handler.Warp        as Warp
 
@@ -52,13 +42,13 @@ import qualified PostgREST.DbStructure              as DbStructure
 import qualified PostgREST.Error                    as Error
 import qualified PostgREST.Logger                   as Logger
 import qualified PostgREST.Middleware               as Middleware
-import qualified PostgREST.OpenAPI                  as OpenAPI
 import qualified PostgREST.Query.QueryBuilder       as QueryBuilder
 import qualified PostgREST.Query.Statements         as Statements
 import qualified PostgREST.RangeQuery               as RangeQuery
 import qualified PostgREST.Request.ApiRequest       as ApiRequest
 import qualified PostgREST.Request.DbRequestBuilder as ReqBuilder
 import qualified PostgREST.Request.Types            as ApiRequestTypes
+import qualified PostgREST.Response                 as Response
 
 import PostgREST.AppState                (AppState)
 import PostgREST.Auth                    (AuthResult (..))
@@ -74,9 +64,6 @@ import PostgREST.DbStructure.Proc        (ProcDescription (..),
                                           ProcVolatility (..))
 import PostgREST.DbStructure.Table       (Table (..))
 import PostgREST.Error                   (Error)
-import PostgREST.GucHeader               (GucHeader,
-                                          addHeadersIfNotIncluded,
-                                          unwrapGucHeader)
 import PostgREST.MediaType               (MTPlanAttrs (..),
                                           MediaType (..))
 import PostgREST.Query.Statements        (ResultSet (..))
@@ -87,14 +74,12 @@ import PostgREST.Request.ApiRequest      (Action (..),
 import PostgREST.Request.Preferences     (PreferCount (..),
                                           PreferParameters (..),
                                           PreferRepresentation (..),
-                                          toAppliedHeader)
+                                          shouldCount)
-import PostgREST.Request.QueryParams     (QueryParams (..))
 import PostgREST.Request.ReadQuery       (ReadRequest, fstFieldNames)
 import PostgREST.Version                 (prettyVersion)
 import PostgREST.Workers                 (connectionWorker, listener)
 
 import qualified PostgREST.DbStructure.Proc as Proc
-import qualified PostgREST.MediaType        as MediaType
 
 import Protolude hiding (Handler)
 
@@ -178,17 +163,12 @@ postgrest logLevel appState connWorker =
         -- Launch the connWorker when the connection is down.  The postgrest
         -- function can respond successfully (with a stale schema cache) before
         -- the connWorker is done.
-        let isPGAway = Wai.responseStatus response == HTTP.status503
+        when (Response.isServiceUnavailable response) connWorker
-        when isPGAway connWorker
+        resp <- do
-        resp <- addRetryHint isPGAway appState response
+          delay <- AppState.getRetryNextIn appState
+          return $ Response.addRetryHint delay response
         respond resp
 
-addRetryHint :: Bool -> AppState -> Wai.Response -> IO Wai.Response
-addRetryHint shouldAdd appState response = do
-  delay <- AppState.getRetryNextIn appState
-  let h = ("Retry-After", BS.pack $ show delay)
-  return $ Wai.mapResponseHeaders (\hs -> if shouldAdd then h:hs else hs) response
-
 postgrestResponse
   :: AppState.AppState
   -> AppConfig
@@ -215,7 +195,7 @@ postgrestResponse appState conf@AppConfig{..} maybeDbStructure jsonDbS pgVer Aut
   let ctx apiReq = RequestContext conf dbStructure apiReq pgVer
 
   if iAction apiRequest == ActionInfo then
-    handleInfo (iTarget apiRequest) (ctx apiRequest)
+    pure $ Response.infoResponse (iTarget apiRequest) dbStructure
   else
     runDbHandler appState (txMode apiRequest) (Just authRole /= configDbAnonRole) configDbPreparedStatements .
       Middleware.optionalRollback conf apiRequest $
@@ -283,30 +263,7 @@ handleRead headersOnly identifier context@RequestContext{..} = do
   failNotSingular iAcceptMediaType resultSet
   total <- readTotal ctxConfig ctxApiRequest resultSet countQuery
 
-  case resultSet of
+  pure $ Response.readResponse headersOnly identifier ctxApiRequest total resultSet
-    RSStandard{..} -> do
-
-      let
-        (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal total
-        response = gucResponse rsGucStatus rsGucHeaders
-        headers =
-          [ contentRange
-          , ( "Content-Location"
-            , "/"
-                <> toUtf8 (qiName identifier)
-                <> if BS.null (qsCanonical iQueryParams) then mempty else "?" <> qsCanonical iQueryParams
-            )
-          ]
-          ++ contentTypeHeaders context
-        rsOrErrBody = if status == HTTP.status416
-          then Error.errorPayload $ Error.ApiRequestError $ ApiRequestTypes.InvalidRange
-            $ ApiRequestTypes.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show total)
-          else LBS.fromStrict rsBody
-
-      pure $ response status headers $ if headersOnly then mempty else rsOrErrBody
-
-    RSPlan plan ->
-      pure $ Wai.responseLBS HTTP.status200 (contentTypeHeaders context) $ LBS.fromStrict plan
 
 readTotal :: AppConfig -> ApiRequest -> ResultSet -> SQL.Snippet -> DbHandler (Maybe Int64)
 readTotal _ _ RSPlan{} _ = pure Nothing
@@ -327,7 +284,7 @@ readTotal AppConfig{..} ApiRequest{..} RSStandard{rsTableTotal=tableTotal} count
         configDbPreparedStatements
 
 handleCreate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
-handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
+handleCreate identifier context@RequestContext{..} = do
   let
     ApiRequest{..} = ctxApiRequest
     pkCols = if iPreferRepresentation /= None || isJust iPreferResolution
@@ -338,140 +295,42 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
 
   failNotSingular iAcceptMediaType resultSet
 
-  case resultSet of
+  pure $ Response.createResponse identifier pkCols ctxApiRequest resultSet
-    RSStandard{..} -> do
-      let
-        response = gucResponse rsGucStatus rsGucHeaders
-        headers =
-          catMaybes
-            [ if null rsLocation then
-                Nothing
-              else
-                Just
-                  ( HTTP.hLocation
-                  , "/"
-                      <> toUtf8 qiName
-                      <> HTTP.renderSimpleQuery True rsLocation
-                  )
-            , Just . RangeQuery.contentRangeH 1 0 $
-                if shouldCount iPreferCount then Just rsQueryTotal else Nothing
-            , if null pkCols && isNothing (qsOnConflict iQueryParams) then
-                Nothing
-              else
-                toAppliedHeader <$> iPreferResolution
-            ]
-
-      pure $ if iPreferRepresentation == Full then
-        response HTTP.status201 (headers ++ contentTypeHeaders context) (LBS.fromStrict rsBody)
-      else
-        response HTTP.status201 headers mempty
-
-    RSPlan plan ->
-      pure $ Wai.responseLBS HTTP.status200 (contentTypeHeaders context) $ LBS.fromStrict plan
 
 handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
-handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do
+handleUpdate identifier context@(RequestContext _ _ ctxApiRequest@ApiRequest{..} _) = do
   resultSet <- writeQuery MutationUpdate identifier False mempty context
   failNotSingular iAcceptMediaType resultSet
   failsChangesOffLimits (RangeQuery.rangeLimit iTopLevelRange) resultSet
 
-  case resultSet of
+  pure $ Response.updateResponse ctxApiRequest resultSet
-    RSStandard{..} -> do
-      let
-        response = gucResponse rsGucStatus rsGucHeaders
-        fullRepr = iPreferRepresentation == Full
-        updateIsNoOp = S.null iColumns
-        status
-          | rsQueryTotal == 0 && not updateIsNoOp = HTTP.status404
-          | fullRepr = HTTP.status200
-          | otherwise = HTTP.status204
-        contentRangeHeader =
-          RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
-            if shouldCount iPreferCount then Just rsQueryTotal else Nothing
-
-      pure $ if fullRepr then
-          response status (contentTypeHeaders context ++ [contentRangeHeader]) (LBS.fromStrict rsBody)
-        else
-          response status [contentRangeHeader] mempty
-
-    RSPlan plan ->
-      pure $ Wai.responseLBS HTTP.status200 (contentTypeHeaders context) $ LBS.fromStrict plan
 
 handleSingleUpsert :: QualifiedIdentifier -> RequestContext-> DbHandler Wai.Response
-handleSingleUpsert identifier context@(RequestContext _ ctxDbStructure ApiRequest{..} _) = do
+handleSingleUpsert identifier context@(RequestContext _ ctxDbStructure ctxApiRequest _) = do
   let pkCols = maybe mempty tablePKCols $ HM.lookup identifier $ dbTables ctxDbStructure
-
   resultSet <- writeQuery MutationSingleUpsert identifier False pkCols context
+  failPut resultSet
+  pure $ Response.singleUpsertResponse ctxApiRequest resultSet
 
-  case resultSet of
+-- Makes sure the querystring pk matches the payload pk
-    RSStandard {..} -> do
+-- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted,
-      let
+-- PUT /items?id=eq.14 { "id" : 2, .. } is rejected.
-        response = gucResponse rsGucStatus rsGucHeaders
+-- If this condition is not satisfied then nothing is inserted,
-
+-- check the WHERE for INSERT in QueryBuilder.hs to see how it's done
-      -- Makes sure the querystring pk matches the payload pk
+failPut :: ResultSet -> DbHandler ()
-      -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted,
+failPut RSPlan{} = pure ()
-      -- PUT /items?id=eq.14 { "id" : 2, .. } is rejected.
+failPut RSStandard{rsQueryTotal=queryTotal} =
-      -- If this condition is not satisfied then nothing is inserted,
+  when (queryTotal /= 1) $ do
-      -- check the WHERE for INSERT in QueryBuilder.hs to see how it's done
+    lift SQL.condemn
-      when (rsQueryTotal /= 1) $ do
+    throwError Error.PutMatchingPkError
-        lift SQL.condemn
-        throwError Error.PutMatchingPkError
-
-      return $
-        if iPreferRepresentation == Full then
-          response HTTP.status200 (contentTypeHeaders context) (LBS.fromStrict rsBody)
-        else
-          response HTTP.status204 [] mempty
-
-    RSPlan plan ->
-      pure $ Wai.responseLBS HTTP.status200 (contentTypeHeaders context) $ LBS.fromStrict plan
 
 handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
-handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do
+handleDelete identifier context@(RequestContext _ _ ctxApiRequest@ApiRequest{..} _) = do
   resultSet <- writeQuery MutationDelete identifier False mempty context
   failNotSingular iAcceptMediaType resultSet
   failsChangesOffLimits (RangeQuery.rangeLimit iTopLevelRange) resultSet
 
-  case resultSet of
+  pure $ Response.deleteResponse ctxApiRequest resultSet
-    RSStandard {..} -> do
-      let
-        response = gucResponse rsGucStatus rsGucHeaders
-        contentRangeHeader =
-          RangeQuery.contentRangeH 1 0 $
-            if shouldCount iPreferCount then Just rsQueryTotal else Nothing
-
-      pure $ if iPreferRepresentation == Full then
-          response HTTP.status200
-            (contentTypeHeaders context ++ [contentRangeHeader])
-            (LBS.fromStrict rsBody)
-        else
-          response HTTP.status204 [contentRangeHeader] mempty
-
-    RSPlan plan ->
-      pure $ Wai.responseLBS HTTP.status200 (contentTypeHeaders context) $ LBS.fromStrict plan
-
-handleInfo :: Monad m => Target -> RequestContext -> Handler m Wai.Response
-handleInfo target RequestContext{..} =
-  case target of
-    TargetIdent identifier ->
-      case HM.lookup identifier (dbTables ctxDbStructure) of
-        Just tbl -> infoResponse $ allowH tbl
-        Nothing  -> throwError $ Error.ApiRequestError ApiRequestTypes.NotFound
-    TargetProc pd _
-      | pdVolatility pd == Volatile -> infoResponse "OPTIONS,POST"
-      | otherwise                   -> infoResponse "OPTIONS,GET,HEAD,POST"
-    TargetDefaultSpec _             -> infoResponse "OPTIONS,GET,HEAD"
-  where
-    infoResponse allowHeader = return $ Wai.responseLBS HTTP.status200 [allOrigins, (HTTP.hAllow, allowHeader)] mempty
-    allOrigins = ("Access-Control-Allow-Origin", "*")
-    allowH table =
-      let hasPK = not . null $ tablePKCols table in
-      BS.intercalate "," $
-          ["OPTIONS,GET,HEAD"] ++
-          ["POST" | tableInsertable table] ++
-          ["PUT" | tableInsertable table && tableUpdatable table && hasPK] ++
-          ["PATCH" | tableUpdatable table] ++
-          ["DELETE" | tableDeletable table]
 
 handleInvoke :: InvokeMethod -> ProcDescription -> RequestContext -> DbHandler Wai.Response
 handleInvoke invMethod proc context@RequestContext{..} = do
@@ -503,49 +362,26 @@ handleInvoke invMethod proc context@RequestContext{..} = do
         (configDbPreparedStatements ctxConfig)
 
   failNotSingular iAcceptMediaType resultSet
-
+  pure $ Response.invokeResponse invMethod proc ctxApiRequest resultSet
-  case resultSet of
-    RSStandard {..} -> do
-      let
-        response = gucResponse rsGucStatus rsGucHeaders
-        (status, contentRange) =
-          RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
-        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
-
-      pure $ if Proc.procReturnsVoid proc then
-          response HTTP.status204 [contentRange] mempty
-        else
-          response status
-            (contentTypeHeaders context ++ [contentRange])
-            (if invMethod == InvHead then mempty else rsOrErrBody)
-
-    RSPlan plan ->
-      pure $ Wai.responseLBS HTTP.status200 (contentTypeHeaders context) $ LBS.fromStrict plan
 
 handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response
 handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest ctxPgVersion) = do
   body <-
     lift $ case configOpenApiMode of
       OAFollowPriv ->
-        OpenAPI.encode conf dbStructure
+        Just <$> ((,,)
            <$> SQL.statement [tSchema] (DbStructure.accessibleTables ctxPgVersion configDbPreparedStatements)
            <*> SQL.statement tSchema (DbStructure.accessibleProcs ctxPgVersion configDbPreparedStatements)
-           <*> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements)
+           <*> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements))
       OAIgnorePriv ->
-        OpenAPI.encode conf dbStructure
+        Just <$> ((,,)
               (HM.filterWithKey (\(QualifiedIdentifier sch _) _ ->  sch == tSchema) $ DbStructure.dbTables dbStructure)
               (HM.filterWithKey (\(QualifiedIdentifier sch _) _ ->  sch == tSchema) $ DbStructure.dbProcs dbStructure)
-          <$> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements)
+          <$> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements))
       OADisabled ->
-        pure mempty
+        pure Nothing
 
-  return $
+  pure $ Response.openApiResponse headersOnly body conf dbStructure $ iProfile apiRequest
-    Wai.responseLBS HTTP.status200
-      (MediaType.toContentType MTOpenAPI : maybeToList (profileHeader apiRequest))
-      (if headersOnly then mempty else body)
 
 txMode :: ApiRequest -> SQL.Mode
 txMode ApiRequest{..} =
@@ -587,28 +423,6 @@ writeQuery mutation identifier@QualifiedIdentifier{..} isInsert pkCols context@R
       pkCols
       (configDbPreparedStatements ctxConfig)
 
--- | Response with headers and status overridden from GUCs.
-gucResponse
-  :: Maybe Text
-  -> Maybe BS.ByteString
-  -> HTTP.Status
-  -> [HTTP.Header]
-  -> 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 [GucHeader]
-decodeGucHeaders =
-  maybe (Right []) $ first (const Error.GucHeadersError) . JSON.eitherDecode . LBS.fromStrict
-
-decodeGucStatus :: Maybe Text -> Either Error (Maybe Status)
-decodeGucStatus =
-  maybe (Right Nothing) $ first (const Error.GucStatusError) . fmap (Just . toEnum . fst) . decimal
-
 -- |
 -- Fail a response if a single JSON object was requested and not exactly one
 -- was found.
@@ -627,10 +441,6 @@ failsChangesOffLimits (Just maxChanges) RSStandard{rsQueryTotal=queryTotal} =
     lift SQL.condemn
     throwError $ Error.OffLimitsChangesError queryTotal maxChanges
 
-shouldCount :: Maybe PreferCount -> Bool
-shouldCount preferCount =
-  preferCount == Just ExactCount || preferCount == Just EstimatedCount
-
 returnsScalar :: ApiRequest.Target -> Bool
 returnsScalar (TargetProc proc _) = Proc.procReturnsScalar proc
 returnsScalar _                   = False
@@ -642,10 +452,6 @@ readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure ap
       (dbRelationships dbStructure)
       apiRequest
 
-contentTypeHeaders :: RequestContext -> [HTTP.Header]
-contentTypeHeaders RequestContext{..} =
-  MediaType.toContentType (iAcceptMediaType ctxApiRequest) : maybeToList (profileHeader ctxApiRequest)
-
 -- | If raw(binary) output is requested, check that MediaType is one of the
 -- admitted rawMediaTypes and that`?select=...` contains only one field other
 -- than `*`
@@ -672,7 +478,3 @@ binaryField RequestContext{..} readReq
       MTPlan (MTPlanAttrs (Just MTTextPlain) _ _)   -> True
       MTPlan (MTPlanAttrs (Just MTTextXML) _ _)     -> True
       _                                             -> False
-
-profileHeader :: ApiRequest -> Maybe HTTP.Header
-profileHeader ApiRequest{..} =
-  (,) "Content-Profile" <$> (toUtf8 <$> iProfile)

src/PostgREST/Request/Preferences.hs

@@ -15,6 +15,7 @@ module PostgREST.Request.Preferences
   , PreferTransaction(..)
   , fromHeaders
   , ToAppliedHeader(..)
+  , shouldCount
   ) where
 
 import qualified Data.ByteString.Char8     as BS
@@ -188,6 +189,10 @@ instance ToHeaderValue PreferCount where
   toHeaderValue PlannedCount   = "count=planned"
   toHeaderValue EstimatedCount = "count=estimated"
 
+shouldCount :: Maybe PreferCount -> Bool
+shouldCount prefCount =
+  prefCount == Just ExactCount || prefCount == Just EstimatedCount
+
 -- | Whether to commit or roll back transactions.
 data PreferTransaction
   = Commit   -- ^ Commit transaction - the default.

src/PostgREST/Response.hs

@@ -0,0 +1,260 @@
+{-# LANGUAGE RecordWildCards #-}
+module PostgREST.Response
+  ( createResponse
+  , deleteResponse
+  , infoResponse
+  , invokeResponse
+  , openApiResponse
+  , readResponse
+  , singleUpsertResponse
+  , updateResponse
+  , addRetryHint
+  , isServiceUnavailable
+  ) where
+
+import qualified Data.Aeson                as JSON
+import qualified Data.ByteString.Char8     as BS
+import qualified Data.ByteString.Lazy      as LBS
+import qualified Data.HashMap.Strict       as HM
+import qualified Data.Set                  as S
+import           Data.Text.Read            (decimal)
+import qualified Network.HTTP.Types.Header as HTTP
+import qualified Network.HTTP.Types.Status as HTTP
+import qualified Network.HTTP.Types.URI    as HTTP
+import qualified Network.Wai               as Wai
+
+import qualified PostgREST.Error      as Error
+import qualified PostgREST.MediaType  as MediaType
+import qualified PostgREST.OpenAPI    as OpenAPI
+import qualified PostgREST.RangeQuery as RangeQuery
+
+import PostgREST.Config                  (AppConfig (..))
+import PostgREST.DbStructure             (DbStructure (..))
+import PostgREST.DbStructure.Identifiers (FieldName,
+                                          QualifiedIdentifier (..),
+                                          Schema)
+import PostgREST.DbStructure.Proc        (ProcDescription (..),
+                                          ProcVolatility (..),
+                                          ProcsMap)
+import PostgREST.DbStructure.Table       (Table (..), TablesMap)
+import PostgREST.GucHeader               (GucHeader,
+                                          addHeadersIfNotIncluded,
+                                          unwrapGucHeader)
+import PostgREST.MediaType               (MediaType (..))
+import PostgREST.Query.Statements        (ResultSet (..))
+import PostgREST.Request.ApiRequest      (ApiRequest (..),
+                                          InvokeMethod (..),
+                                          Target (..))
+import PostgREST.Request.Preferences     (PreferRepresentation (..),
+                                          shouldCount,
+                                          toAppliedHeader)
+import PostgREST.Request.QueryParams     (QueryParams (..))
+
+import qualified PostgREST.DbStructure.Proc as Proc
+import qualified PostgREST.Request.Types    as ApiRequestTypes
+
+import Protolude      hiding (Handler, toS)
+import Protolude.Conv (toS)
+
+
+readResponse :: Bool -> QualifiedIdentifier -> ApiRequest -> Maybe Int64 -> ResultSet -> Wai.Response
+readResponse headersOnly identifier ctxApiRequest@ApiRequest{..} total resultSet = case resultSet of
+  RSStandard{..} -> do
+    let
+      (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal total
+      response = gucResponse rsGucStatus rsGucHeaders
+      headers =
+        [ contentRange
+        , ( "Content-Location"
+          , "/"
+              <> toUtf8 (qiName identifier)
+              <> if BS.null (qsCanonical iQueryParams) then mempty else "?" <> qsCanonical iQueryParams
+          )
+        ]
+        ++ contentTypeHeaders ctxApiRequest
+      rsOrErrBody = if status == HTTP.status416
+        then Error.errorPayload $ Error.ApiRequestError $ ApiRequestTypes.InvalidRange
+          $ ApiRequestTypes.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show total)
+        else LBS.fromStrict rsBody
+
+    response status headers $ if headersOnly then mempty else rsOrErrBody
+
+  RSPlan plan ->
+    Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
+
+createResponse :: QualifiedIdentifier -> [FieldName] -> ApiRequest -> ResultSet -> Wai.Response
+createResponse QualifiedIdentifier{..} pkCols ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+  RSStandard{..} -> do
+    let
+      response = gucResponse rsGucStatus rsGucHeaders
+      headers =
+        catMaybes
+          [ if null rsLocation then
+              Nothing
+            else
+              Just
+                ( HTTP.hLocation
+                , "/"
+                    <> toUtf8 qiName
+                    <> HTTP.renderSimpleQuery True rsLocation
+                )
+          , Just . RangeQuery.contentRangeH 1 0 $
+              if shouldCount iPreferCount then Just rsQueryTotal else Nothing
+          , if null pkCols && isNothing (qsOnConflict iQueryParams) then
+              Nothing
+            else
+              toAppliedHeader <$> iPreferResolution
+          ]
+
+    if iPreferRepresentation == Full then
+      response HTTP.status201 (headers ++ contentTypeHeaders ctxApiRequest) (LBS.fromStrict rsBody)
+    else
+      response HTTP.status201 headers mempty
+
+  RSPlan plan ->
+    Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
+
+updateResponse :: ApiRequest -> ResultSet -> Wai.Response
+updateResponse ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+  RSStandard{..} -> do
+    let
+      response = gucResponse rsGucStatus rsGucHeaders
+      fullRepr = iPreferRepresentation == Full
+      updateIsNoOp = S.null iColumns
+      status
+        | rsQueryTotal == 0 && not updateIsNoOp = HTTP.status404
+        | fullRepr = HTTP.status200
+        | otherwise = HTTP.status204
+      contentRangeHeader =
+        RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
+          if shouldCount iPreferCount then Just rsQueryTotal else Nothing
+
+    if fullRepr then
+        response status (contentTypeHeaders ctxApiRequest ++ [contentRangeHeader]) (LBS.fromStrict rsBody)
+      else
+        response status [contentRangeHeader] mempty
+
+  RSPlan plan ->
+    Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
+
+singleUpsertResponse :: ApiRequest -> ResultSet -> Wai.Response
+singleUpsertResponse ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+  RSStandard {..} -> do
+    let
+      response = gucResponse rsGucStatus rsGucHeaders
+
+    if iPreferRepresentation == Full then
+      response HTTP.status200 (contentTypeHeaders ctxApiRequest) (LBS.fromStrict rsBody)
+    else
+      response HTTP.status204 [] mempty
+
+  RSPlan plan ->
+    Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
+
+deleteResponse :: ApiRequest -> ResultSet -> Wai.Response
+deleteResponse ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+  RSStandard {..} -> do
+    let
+      response = gucResponse rsGucStatus rsGucHeaders
+      contentRangeHeader =
+        RangeQuery.contentRangeH 1 0 $
+          if shouldCount iPreferCount then Just rsQueryTotal else Nothing
+
+    if iPreferRepresentation == Full then
+        response HTTP.status200
+          (contentTypeHeaders ctxApiRequest ++ [contentRangeHeader])
+          (LBS.fromStrict rsBody)
+      else
+        response HTTP.status204 [contentRangeHeader] mempty
+
+  RSPlan plan ->
+    Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
+
+infoResponse :: Target -> DbStructure -> Wai.Response
+infoResponse target dbStructure =
+  case target of
+    TargetIdent identifier ->
+      case HM.lookup identifier (dbTables dbStructure) of
+        Just tbl -> respondInfo $ allowH tbl
+        Nothing  -> Error.errorResponseFor $ Error.ApiRequestError ApiRequestTypes.NotFound
+    TargetProc pd _
+      | pdVolatility pd == Volatile -> respondInfo "OPTIONS,POST"
+      | otherwise                   -> respondInfo "OPTIONS,GET,HEAD,POST"
+    TargetDefaultSpec _             -> respondInfo "OPTIONS,GET,HEAD"
+  where
+    respondInfo allowHeader = Wai.responseLBS HTTP.status200 [allOrigins, (HTTP.hAllow, allowHeader)] mempty
+    allOrigins = ("Access-Control-Allow-Origin", "*")
+    allowH table =
+      let hasPK = not . null $ tablePKCols table in
+      BS.intercalate "," $
+          ["OPTIONS,GET,HEAD"] ++
+          ["POST" | tableInsertable table] ++
+          ["PUT" | tableInsertable table && tableUpdatable table && hasPK] ++
+          ["PATCH" | tableUpdatable table] ++
+          ["DELETE" | tableDeletable table]
+
+invokeResponse :: InvokeMethod -> ProcDescription -> ApiRequest -> ResultSet -> Wai.Response
+invokeResponse invMethod proc ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+  RSStandard {..} -> do
+    let
+      response = gucResponse rsGucStatus rsGucHeaders
+      (status, contentRange) =
+        RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
+      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
+
+    if Proc.procReturnsVoid proc then
+        response HTTP.status204 [contentRange] mempty
+      else
+        response status
+          (contentTypeHeaders ctxApiRequest ++ [contentRange])
+          (if invMethod == InvHead then mempty else rsOrErrBody)
+
+  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 headersOnly body conf dbStructure iProfile =
+  Wai.responseLBS HTTP.status200
+    (MediaType.toContentType MTOpenAPI : maybeToList (profileHeader iProfile))
+    (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.
+gucResponse
+  :: Maybe Text
+  -> Maybe BS.ByteString
+  -> HTTP.Status
+  -> [HTTP.Header]
+  -> 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 =
+  maybe (Right []) $ first (const Error.GucHeadersError) . JSON.eitherDecode . LBS.fromStrict
+
+decodeGucStatus :: Maybe Text -> Either Error.Error (Maybe HTTP.Status)
+decodeGucStatus =
+  maybe (Right Nothing) $ first (const Error.GucStatusError) . fmap (Just . toEnum . fst) . decimal
+
+contentTypeHeaders :: ApiRequest -> [HTTP.Header]
+contentTypeHeaders ApiRequest{..} =
+  MediaType.toContentType iAcceptMediaType : maybeToList (profileHeader iProfile)
+
+profileHeader :: Maybe Schema -> Maybe HTTP.Header
+profileHeader iProfile =
+  (,) "Content-Profile" <$> (toS <$> iProfile)
+
+addRetryHint :: Int -> Wai.Response -> Wai.Response
+addRetryHint delay response = do
+  let h = ("Retry-After", BS.pack $ show delay)
+  Wai.mapResponseHeaders (\hs -> if isServiceUnavailable response then h:hs else hs) response
+
+isServiceUnavailable :: Wai.Response -> Bool
+isServiceUnavailable response = Wai.responseStatus response == HTTP.status503