From 9eddc2d26352342db9e1d981b76d990aaa8f7848 Mon Sep 17 00:00:00 2001 From: steve-chavez Date: Fri, 23 Sep 2022 00:33:42 -0500 Subject: [PATCH 1/3] refactor: move guc headers/status decoding to App --- src/PostgREST/App.hs | 44 +++++++++++++++++++------------ src/PostgREST/Query/Statements.hs | 25 +++++------------- 2 files changed, 33 insertions(+), 36 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 17bf4a16ac..a26ae85b1a 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -17,6 +17,10 @@ module PostgREST.App , run ) 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) @@ -26,6 +30,7 @@ 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 @@ -278,10 +283,10 @@ handleRead headersOnly identifier context@RequestContext{..} = do case resultSet of RSStandard{..} -> do total <- readTotal ctxConfig ctxApiRequest rsTableTotal countQuery - response <- liftEither $ gucResponse <$> rsGucStatus <*> rsGucHeaders let (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal total + response = gucResponse rsGucStatus rsGucHeaders headers = [ contentRange , ( "Content-Location" @@ -331,10 +336,8 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do case resultSet of RSStandard{..} -> do - - response <- liftEither $ gucResponse <$> rsGucStatus <*> rsGucHeaders - let + response = gucResponse rsGucStatus rsGucHeaders headers = catMaybes [ if null rsLocation then @@ -369,9 +372,8 @@ handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do case resultSet of RSStandard{..} -> do - response <- liftEither $ gucResponse <$> rsGucStatus <*> rsGucHeaders - let + response = gucResponse rsGucStatus rsGucHeaders fullRepr = iPreferRepresentation == Full updateIsNoOp = S.null iColumns status @@ -400,8 +402,8 @@ handleSingleUpsert identifier context@(RequestContext _ ctxDbStructure ApiReques case resultSet of RSStandard {..} -> do - - response <- liftEither $ gucResponse <$> rsGucStatus <*> rsGucHeaders + let + response = gucResponse rsGucStatus rsGucHeaders -- Makes sure the querystring pk matches the payload pk -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, @@ -427,10 +429,8 @@ handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do case resultSet of RSStandard {..} -> do - - response <- liftEither $ gucResponse <$> rsGucStatus <*> rsGucHeaders - let + response = gucResponse rsGucStatus rsGucHeaders contentRangeHeader = RangeQuery.contentRangeH 1 0 $ if shouldCount iPreferCount then Just rsQueryTotal else Nothing @@ -501,8 +501,8 @@ handleInvoke invMethod proc context@RequestContext{..} = do case resultSet of RSStandard {..} -> do - response <- liftEither $ gucResponse <$> rsGucStatus <*> rsGucHeaders let + response = gucResponse rsGucStatus rsGucHeaders (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal rsOrErrBody = if status == HTTP.status416 @@ -585,15 +585,25 @@ writeQuery mutation identifier@QualifiedIdentifier{..} isInsert pkCols context@R -- | Response with headers and status overridden from GUCs. gucResponse - :: Maybe HTTP.Status - -> [GucHeader] + :: Maybe Text + -> Maybe BS.ByteString -> HTTP.Status -> [HTTP.Header] -> LBS.ByteString -> Wai.Response -gucResponse gucStatus gucHeaders status headers = - Wai.responseLBS (fromMaybe status gucStatus) $ - addHeadersIfNotIncluded headers (map unwrapGucHeader gucHeaders) +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 diff --git a/src/PostgREST/Query/Statements.hs b/src/PostgREST/Query/Statements.hs index d8ba389ff3..41851e17a7 100644 --- a/src/PostgREST/Query/Statements.hs +++ b/src/PostgREST/Query/Statements.hs @@ -15,10 +15,8 @@ module PostgREST.Query.Statements , ResultSet (..) ) where -import qualified Data.Aeson as JSON import qualified Data.Aeson.Lens as L import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as LBS import qualified Hasql.Decoders as HD import qualified Hasql.DynamicStatements.Snippet as SQL import qualified Hasql.DynamicStatements.Statement as SQL @@ -26,11 +24,6 @@ import qualified Hasql.Statement as SQL import Control.Lens ((^?)) import Data.Maybe (fromJust) -import Data.Text.Read (decimal) -import Network.HTTP.Types.Status (Status) - -import PostgREST.Error (Error (..)) -import PostgREST.GucHeader (GucHeader) import PostgREST.DbStructure.Identifiers (FieldName) import PostgREST.MediaType (MTPlanAttrs (..), @@ -54,9 +47,9 @@ data ResultSet -- variable bindings like @"k1=eq.42"@, or the empty list if there is no location header. , rsBody :: BS.ByteString -- ^ the aggregated body of the query - , rsGucHeaders :: Either Error [GucHeader] + , rsGucHeaders :: Maybe BS.ByteString -- ^ the HTTP headers to be added to the response - , rsGucStatus :: Either Error (Maybe Status) + , rsGucStatus :: Maybe Text -- ^ the HTTP status to be added to the response } | RSPlan BS.ByteString -- ^ the plan of the query @@ -104,7 +97,7 @@ prepareWrite selectQuery mutateQuery isInsert mt rep pKeys = decodeIt :: HD.Result ResultSet decodeIt = case mt of MTPlan{} -> planRow - _ -> fromMaybe (RSStandard Nothing 0 mempty mempty (Right []) (Right Nothing)) <$> HD.rowMaybe (standardRow False) + _ -> fromMaybe (RSStandard Nothing 0 mempty mempty Nothing Nothing) <$> HD.rowMaybe (standardRow False) prepareRead :: SQL.Snippet -> SQL.Snippet -> Bool -> MediaType -> Maybe FieldName -> Bool -> SQL.Statement () ResultSet prepareRead selectQuery countQuery countTotal mt binaryField = @@ -169,7 +162,7 @@ prepareCall returnsScalar returnsSingle callProcQuery selectQuery countQuery cou decodeIt :: HD.Result ResultSet decodeIt = case mt of MTPlan{} -> planRow - _ -> fromMaybe (RSStandard (Just 0) 0 mempty mempty (Right []) (Right Nothing)) <$> HD.rowMaybe (standardRow True) + _ -> fromMaybe (RSStandard (Just 0) 0 mempty mempty Nothing Nothing) <$> HD.rowMaybe (standardRow True) preparePlanRows :: SQL.Snippet -> Bool -> SQL.Statement () (Maybe Int64) preparePlanRows countQuery = @@ -185,8 +178,8 @@ standardRow :: Bool -> HD.Row ResultSet standardRow noLocation = RSStandard <$> nullableColumn HD.int8 <*> column HD.int8 <*> (if noLocation then pure mempty else fmap splitKeyValue <$> arrayColumn HD.bytea) <*> column HD.bytea - <*> (fromMaybe (Right []) <$> nullableColumn decodeGucHeaders) - <*> (fromMaybe (Right Nothing) <$> nullableColumn decodeGucStatus) + <*> nullableColumn HD.bytea + <*> nullableColumn HD.text where splitKeyValue :: ByteString -> (ByteString, ByteString) splitKeyValue kv = @@ -202,12 +195,6 @@ mtSnippet mediaType snippet = case mediaType of planRow :: HD.Result ResultSet planRow = RSPlan . BS.unlines <$> HD.rowList (column HD.bytea) -decodeGucHeaders :: HD.Value (Either Error [GucHeader]) -decodeGucHeaders = first (const GucHeadersError) . JSON.eitherDecode . LBS.fromStrict <$> HD.bytea - -decodeGucStatus :: HD.Value (Either Error (Maybe Status)) -decodeGucStatus = first (const GucStatusError) . fmap (Just . toEnum . fst) . decimal <$> HD.text - column :: HD.Value a -> HD.Row a column = HD.column . HD.nonNullable From 3a2b0bb3dfb7452207246e2fef4790219f173d84 Mon Sep 17 00:00:00 2001 From: steve-chavez Date: Fri, 23 Sep 2022 19:39:10 -0500 Subject: [PATCH 2/3] refactor: untangle query logic from response logic * untangle failNotSingular * untangle failsChangesOffLimits * untangle readTotal --- src/PostgREST/App.hs | 90 +++++++++++++++---------------- src/PostgREST/Query/Statements.hs | 4 +- 2 files changed, 47 insertions(+), 47 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index a26ae85b1a..4d70808883 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -30,7 +30,7 @@ import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort, setServerName) import System.Posix.Types (FileMode) -import qualified Data.Aeson as JSON +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 @@ -280,9 +280,11 @@ handleRead headersOnly identifier context@RequestContext{..} = do bField configDbPreparedStatements + failNotSingular iAcceptMediaType resultSet + total <- readTotal ctxConfig ctxApiRequest resultSet countQuery + case resultSet of RSStandard{..} -> do - total <- readTotal ctxConfig ctxApiRequest rsTableTotal countQuery let (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal total @@ -301,14 +303,14 @@ handleRead headersOnly identifier context@RequestContext{..} = do $ ApiRequestTypes.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show total) else LBS.fromStrict rsBody - failNotSingular iAcceptMediaType rsQueryTotal . response status headers $ - if headersOnly then mempty else rsOrErrBody + 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 -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64) -readTotal AppConfig{..} ApiRequest{..} tableTotal countQuery = +readTotal :: AppConfig -> ApiRequest -> ResultSet -> SQL.Snippet -> DbHandler (Maybe Int64) +readTotal _ _ RSPlan{} _ = pure Nothing +readTotal AppConfig{..} ApiRequest{..} RSStandard{rsTableTotal=tableTotal} countQuery = case iPreferCount of Just PlannedCount -> explain @@ -334,6 +336,8 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do resultSet <- writeQuery MutationCreate identifier True pkCols context + failNotSingular iAcceptMediaType resultSet + case resultSet of RSStandard{..} -> do let @@ -357,11 +361,10 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do toAppliedHeader <$> iPreferResolution ] - failNotSingular iAcceptMediaType rsQueryTotal $ - if iPreferRepresentation == Full then - response HTTP.status201 (headers ++ contentTypeHeaders context) (LBS.fromStrict rsBody) - else - response HTTP.status201 headers mempty + 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 @@ -369,6 +372,8 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do resultSet <- writeQuery MutationUpdate identifier False mempty context + failNotSingular iAcceptMediaType resultSet + failsChangesOffLimits (RangeQuery.rangeLimit iTopLevelRange) resultSet case resultSet of RSStandard{..} -> do @@ -384,12 +389,10 @@ handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $ if shouldCount iPreferCount then Just rsQueryTotal else Nothing - failChangesOffLimits (RangeQuery.rangeLimit iTopLevelRange) rsQueryTotal =<< - failNotSingular iAcceptMediaType rsQueryTotal ( - if fullRepr then - response status (contentTypeHeaders context ++ [contentRangeHeader]) (LBS.fromStrict rsBody) - else - response status [contentRangeHeader] mempty) + 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 @@ -426,6 +429,8 @@ handleSingleUpsert identifier context@(RequestContext _ ctxDbStructure ApiReques handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do resultSet <- writeQuery MutationDelete identifier False mempty context + failNotSingular iAcceptMediaType resultSet + failsChangesOffLimits (RangeQuery.rangeLimit iTopLevelRange) resultSet case resultSet of RSStandard {..} -> do @@ -435,14 +440,12 @@ handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do RangeQuery.contentRangeH 1 0 $ if shouldCount iPreferCount then Just rsQueryTotal else Nothing - failChangesOffLimits (RangeQuery.rangeLimit iTopLevelRange) rsQueryTotal =<< - failNotSingular iAcceptMediaType rsQueryTotal ( - if iPreferRepresentation == Full then - response HTTP.status200 - (contentTypeHeaders context ++ [contentRangeHeader]) - (LBS.fromStrict rsBody) - else - response HTTP.status204 [contentRangeHeader] mempty) + 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 @@ -499,6 +502,8 @@ handleInvoke invMethod proc context@RequestContext{..} = do bField (configDbPreparedStatements ctxConfig) + failNotSingular iAcceptMediaType resultSet + case resultSet of RSStandard {..} -> do let @@ -510,8 +515,7 @@ handleInvoke invMethod proc context@RequestContext{..} = do $ ApiRequestTypes.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal) else LBS.fromStrict rsBody - failNotSingular iAcceptMediaType rsQueryTotal $ - if Proc.procReturnsVoid proc then + pure $ if Proc.procReturnsVoid proc then response HTTP.status204 [contentRange] mempty else response status @@ -608,24 +612,20 @@ decodeGucStatus = -- | -- Fail a response if a single JSON object was requested and not exactly one -- was found. -failNotSingular :: MediaType -> Int64 -> Wai.Response -> DbHandler Wai.Response -failNotSingular mediaType queryTotal response = - if mediaType == MTSingularJSON && queryTotal /= 1 then - do - lift SQL.condemn - throwError $ Error.singularityError queryTotal - else - return response - -failChangesOffLimits :: Maybe Integer -> Int64 -> Wai.Response -> DbHandler Wai.Response -failChangesOffLimits (Just maxChanges) queryTotal response = - if queryTotal > fromIntegral maxChanges - then do - lift SQL.condemn - throwError $ Error.OffLimitsChangesError queryTotal maxChanges - else - return response -failChangesOffLimits _ _ response = return response +failNotSingular :: MediaType -> ResultSet -> DbHandler () +failNotSingular _ RSPlan{} = pure () +failNotSingular mediaType RSStandard{rsQueryTotal=queryTotal} = + when (mediaType == MTSingularJSON && queryTotal /= 1) $ do + lift SQL.condemn + throwError $ Error.singularityError queryTotal + +failsChangesOffLimits :: Maybe Integer -> ResultSet -> DbHandler () +failsChangesOffLimits _ RSPlan{} = pure () +failsChangesOffLimits Nothing _ = pure () +failsChangesOffLimits (Just maxChanges) RSStandard{rsQueryTotal=queryTotal} = + when (queryTotal > fromIntegral maxChanges) $ do + lift SQL.condemn + throwError $ Error.OffLimitsChangesError queryTotal maxChanges shouldCount :: Maybe PreferCount -> Bool shouldCount preferCount = diff --git a/src/PostgREST/Query/Statements.hs b/src/PostgREST/Query/Statements.hs index 41851e17a7..52471f266e 100644 --- a/src/PostgREST/Query/Statements.hs +++ b/src/PostgREST/Query/Statements.hs @@ -22,8 +22,8 @@ import qualified Hasql.DynamicStatements.Snippet as SQL import qualified Hasql.DynamicStatements.Statement as SQL import qualified Hasql.Statement as SQL -import Control.Lens ((^?)) -import Data.Maybe (fromJust) +import Control.Lens ((^?)) +import Data.Maybe (fromJust) import PostgREST.DbStructure.Identifiers (FieldName) import PostgREST.MediaType (MTPlanAttrs (..), From b5400418c0fa72d71ecb76f042905ccad17617c0 Mon Sep 17 00:00:00 2001 From: steve-chavez Date: Fri, 23 Sep 2022 20:36:19 -0500 Subject: [PATCH 3/3] 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 | 1 + src/PostgREST/App.hs | 270 ++++----------------------- src/PostgREST/Request/Preferences.hs | 5 + src/PostgREST/Response.hs | 260 ++++++++++++++++++++++++++ 4 files changed, 302 insertions(+), 234 deletions(-) create mode 100644 src/PostgREST/Response.hs diff --git a/postgrest.cabal b/postgrest.cabal index 95ae85802d..d3b71aa238 100644 --- a/postgrest.cabal +++ b/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 diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 4d70808883..e26be7f8b5 100644 --- a/src/PostgREST/App.hs +++ b/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) -import PostgREST.Request.QueryParams (QueryParams (..)) + shouldCount) 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 isPGAway connWorker - resp <- addRetryHint isPGAway appState response + when (Response.isServiceUnavailable response) connWorker + resp <- do + 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 - 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 + pure $ Response.readResponse headersOnly identifier ctxApiRequest total resultSet 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 - 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 + pure $ Response.createResponse identifier pkCols ctxApiRequest resultSet 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 - 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 + pure $ Response.updateResponse ctxApiRequest resultSet 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 - - case resultSet of - RSStandard {..} -> do - let - response = gucResponse rsGucStatus rsGucHeaders - - -- Makes sure the querystring pk matches the payload pk - -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, - -- PUT /items?id=eq.14 { "id" : 2, .. } is rejected. - -- If this condition is not satisfied then nothing is inserted, - -- check the WHERE for INSERT in QueryBuilder.hs to see how it's done - when (rsQueryTotal /= 1) $ do - 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 + failPut resultSet + pure $ Response.singleUpsertResponse ctxApiRequest resultSet + +-- Makes sure the querystring pk matches the payload pk +-- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, +-- PUT /items?id=eq.14 { "id" : 2, .. } is rejected. +-- If this condition is not satisfied then nothing is inserted, +-- check the WHERE for INSERT in QueryBuilder.hs to see how it's done +failPut :: ResultSet -> DbHandler () +failPut RSPlan{} = pure () +failPut RSStandard{rsQueryTotal=queryTotal} = + when (queryTotal /= 1) $ do + lift SQL.condemn + throwError Error.PutMatchingPkError 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 - 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] + pure $ Response.deleteResponse ctxApiRequest resultSet 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 - - 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 + pure $ Response.invokeResponse invMethod proc ctxApiRequest resultSet 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 $ - Wai.responseLBS HTTP.status200 - (MediaType.toContentType MTOpenAPI : maybeToList (profileHeader apiRequest)) - (if headersOnly then mempty else body) + pure $ Response.openApiResponse headersOnly body conf dbStructure $ iProfile apiRequest 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) diff --git a/src/PostgREST/Request/Preferences.hs b/src/PostgREST/Request/Preferences.hs index 56a397e671..4b067b063f 100644 --- a/src/PostgREST/Request/Preferences.hs +++ b/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. diff --git a/src/PostgREST/Response.hs b/src/PostgREST/Response.hs new file mode 100644 index 0000000000..6af522828c --- /dev/null +++ b/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