From 3c11c93641ea5373e9efff6c408dbddae1417980 Mon Sep 17 00:00:00 2001 From: Andrei Dziahel Date: Tue, 26 Sep 2023 11:27:30 +0200 Subject: [PATCH] refactor: rest of Response's CRUD-response is pure --- src/PostgREST/App.hs | 12 ++++-- src/PostgREST/Response.hs | 79 +++++++++++++++++++-------------------- 2 files changed, 46 insertions(+), 45 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 827317470e..7921c0b0b9 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -190,22 +190,26 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A (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) -> return $ Response.infoIdentResponse identifier sCache diff --git a/src/PostgREST/Response.hs b/src/PostgREST/Response.hs index 632b667441..5e85a02ac5 100644 --- a/src/PostgREST/Response.hs +++ b/src/PostgREST/Response.hs @@ -158,54 +158,61 @@ updateResponse MutateReadPlan{mrMedia} ctxApiRequest@ApiRequest{iPreferences=Pre prefHeader = prefAppliedHeader $ Preferences Nothing preferRepresentation Nothing preferCount preferTransaction preferMissing headers = catMaybes [contentRangeHeader, prefHeader] ++ serverTimingHeader serverTimingParams - let + let (status, headers', body) = case preferRepresentation of Just Full -> (HTTP.status200, headers ++ contentTypeHeaders mrMedia ctxApiRequest, LBS.fromStrict rsBody) Just None -> (HTTP.status204, headers, mempty) _ -> (HTTP.status204, headers, mempty) (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers' - + Right $ PgrstResponse ovStatus ovHeaders body RSPlan 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 - Just Full -> response HTTP.status200 (cTHeader ++ sTHeader ++ prefHeader) (LBS.fromStrict rsBody) - Just None -> response HTTP.status204 (sTHeader ++ prefHeader) mempty - _ -> response HTTP.status204 (sTHeader ++ prefHeader) mempty + let (status, headers, body) = + case preferRepresentation of + Just Full -> (HTTP.status200, cTHeader ++ sTHeader ++ prefHeader, LBS.fromStrict rsBody) + 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 - Just Full -> response HTTP.status200 (headers ++ contentTypeHeaders mrMedia ctxApiRequest) (LBS.fromStrict rsBody) - Just None -> response HTTP.status204 headers mempty - _ -> response HTTP.status204 headers mempty + let (status, headers', body) = + case preferRepresentation of + Just Full -> (HTTP.status200, headers ++ contentTypeHeaders mrMedia ctxApiRequest, LBS.fromStrict rsBody) + 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 identifier sCache = @@ -234,11 +241,10 @@ respondInfo allowHeader = let allOrigins = ("Access-Control-Allow-Origin", "*") in Wai.responseLBS 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 @@ -248,19 +254,24 @@ 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 - response HTTP.status204 headers mempty - else - response status - (headers ++ contentTypeHeaders crMedia ctxApiRequest) - (if invMethod == InvHead then mempty else rsOrErrBody) + let (status', headers', body) = + if Routine.funcReturnsVoid proc then + (HTTP.status204, headers, mempty) + else + (status, + 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) @@ -271,20 +282,6 @@ overrideStatusHeaders rsGucStatus rsGucHeaders pgrstStatus pgrstHeaders = do gucHeaders <- decodeGucHeaders rsGucHeaders Right (fromMaybe pgrstStatus gucStatus, addHeadersIfNotIncluded pgrstHeaders $ map unwrapGucHeader gucHeaders) --- | 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