steve-chavez
baea47bc85
This splits off the transaction concerns into a MainTx module It's just moving some functions inside the Query module to the MainTx module. Some types names were also changed so they don't have the "Query" prefix, to avoid confusion.
277 lines
14 KiB
Haskell
277 lines
14 KiB
Haskell
{- |
|
|
Module : PostgREST.Response
|
|
Description : Generate HTTP Response
|
|
-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
module PostgREST.Response
|
|
( actionResponse
|
|
, PgrstResponse(..)
|
|
) 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 Data.Maybe (fromJust)
|
|
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 PostgREST.Error as Error
|
|
import qualified PostgREST.MediaType as MediaType
|
|
import qualified PostgREST.RangeQuery as RangeQuery
|
|
import qualified PostgREST.Response.OpenAPI as OpenAPI
|
|
|
|
import PostgREST.ApiRequest (ApiRequest (..))
|
|
import PostgREST.ApiRequest.Preferences (PreferRepresentation (..),
|
|
PreferResolution (..),
|
|
Preferences (..),
|
|
prefAppliedHeader,
|
|
shouldCount)
|
|
import PostgREST.ApiRequest.QueryParams (QueryParams (..))
|
|
import PostgREST.ApiRequest.Types (InvokeMethod (..),
|
|
Mutation (..))
|
|
import PostgREST.Config (AppConfig (..))
|
|
import PostgREST.MainTx (DbResult (..),
|
|
ResultSet (..))
|
|
import PostgREST.MediaType (MediaType (..))
|
|
import PostgREST.Plan (CrudPlan (..),
|
|
InfoPlan (..),
|
|
InspectPlan (..))
|
|
import PostgREST.Plan.MutatePlan (MutatePlan (..))
|
|
import PostgREST.Response.GucHeader (GucHeader, unwrapGucHeader)
|
|
import PostgREST.SchemaCache (SchemaCache (..))
|
|
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
|
|
Schema)
|
|
import PostgREST.SchemaCache.Routine (FuncVolatility (..),
|
|
Routine (..))
|
|
import PostgREST.SchemaCache.Table (Table (..))
|
|
|
|
import qualified PostgREST.SchemaCache.Routine as Routine
|
|
|
|
import Protolude hiding (Handler, toS)
|
|
import Protolude.Conv (toS)
|
|
|
|
data PgrstResponse = PgrstResponse {
|
|
pgrstStatus :: HTTP.Status
|
|
, pgrstHeaders :: [HTTP.Header]
|
|
, pgrstBody :: LBS.ByteString
|
|
}
|
|
|
|
actionResponse :: DbResult -> ApiRequest -> (Text, Text) -> AppConfig -> SchemaCache -> Schema -> Bool -> Either Error.Error PgrstResponse
|
|
|
|
actionResponse (DbCrudResult WrappedReadPlan{pMedia, wrHdrsOnly=headersOnly, crudQi=identifier} RSStandard{..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..},..} _ _ _ _ _ = do
|
|
let
|
|
(status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
|
|
cLHeader = if headersOnly then mempty else [contentLengthHeaderStrict rsBody]
|
|
prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing Nothing preferCount preferTransaction Nothing preferHandling preferTimezone Nothing []
|
|
headers =
|
|
[ contentRange
|
|
, ( "Content-Location"
|
|
, "/"
|
|
<> toUtf8 (qiName identifier)
|
|
<> if BS.null (qsCanonical iQueryParams) then mempty else "?" <> qsCanonical iQueryParams
|
|
)
|
|
]
|
|
++ cLHeader
|
|
++ contentTypeHeaders pMedia ctxApiRequest
|
|
++ prefHeader
|
|
bod | status == HTTP.status416 = Error.errorPayload $ Error.ApiRequestError $ Error.InvalidRange $
|
|
Error.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
|
|
| headersOnly = mempty
|
|
| otherwise = LBS.fromStrict rsBody
|
|
|
|
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers
|
|
|
|
Right $ PgrstResponse ovStatus ovHeaders bod
|
|
|
|
actionResponse (DbCrudResult MutateReadPlan{mrMutation=MutationCreate, mrMutatePlan, pMedia, crudQi=QualifiedIdentifier{..}} RSStandard{..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..}, ..} _ _ _ _ _ = do
|
|
let
|
|
pkCols = case mrMutatePlan of { Insert{insPkCols} -> insPkCols; _ -> mempty;}
|
|
prefHeader = prefAppliedHeader $
|
|
Preferences (if null pkCols && isNothing (qsOnConflict iQueryParams) then Nothing else preferResolution)
|
|
preferRepresentation preferCount preferTransaction preferMissing preferHandling preferTimezone Nothing []
|
|
headers =
|
|
catMaybes
|
|
[ if null rsLocation then
|
|
Nothing
|
|
else
|
|
Just
|
|
( HTTP.hLocation
|
|
, "/"
|
|
<> toUtf8 qiName
|
|
<> HTTP.renderSimpleQuery True rsLocation
|
|
)
|
|
, Just . RangeQuery.contentRangeH 1 0 $
|
|
if shouldCount preferCount then Just rsQueryTotal else Nothing
|
|
, Just $ contentLengthHeaderStrict rsBody
|
|
, prefHeader ]
|
|
|
|
isInsertIfGTZero i =
|
|
if i <= 0 && preferResolution == Just MergeDuplicates then
|
|
HTTP.status200
|
|
else
|
|
HTTP.status201
|
|
status = maybe HTTP.status200 isInsertIfGTZero rsInserted
|
|
(headers', bod) = case preferRepresentation of
|
|
Just Full -> (headers ++ contentTypeHeaders pMedia ctxApiRequest, LBS.fromStrict rsBody)
|
|
Just None -> (headers, mempty)
|
|
Just HeadersOnly -> (headers, mempty)
|
|
Nothing -> (headers, mempty)
|
|
|
|
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'
|
|
|
|
Right $ PgrstResponse ovStatus ovHeaders bod
|
|
|
|
actionResponse (DbCrudResult MutateReadPlan{mrMutation=MutationUpdate, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} _ _ _ _ _ = do
|
|
let
|
|
contentRangeHeader =
|
|
Just . RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
|
|
if shouldCount preferCount then Just rsQueryTotal else Nothing
|
|
prefHeader = prefAppliedHeader $ Preferences Nothing preferRepresentation preferCount preferTransaction preferMissing preferHandling preferTimezone preferMaxAffected []
|
|
headers = catMaybes [contentRangeHeader, prefHeader]
|
|
|
|
let (status, headers', body) =
|
|
case preferRepresentation of
|
|
Just Full -> (HTTP.status200, headers ++ [contentLengthHeaderStrict rsBody] ++ contentTypeHeaders pMedia 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
|
|
|
|
actionResponse (DbCrudResult MutateReadPlan{mrMutation=MutationSingleUpsert, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} _ _ _ _ _ = do
|
|
let
|
|
prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing preferRepresentation preferCount preferTransaction Nothing preferHandling preferTimezone Nothing []
|
|
cLHeader = [contentLengthHeaderStrict rsBody]
|
|
cTHeader = contentTypeHeaders pMedia ctxApiRequest
|
|
|
|
let isInsertIfGTZero i = if i > 0 then HTTP.status201 else HTTP.status200
|
|
upsertStatus = isInsertIfGTZero $ fromJust rsInserted
|
|
(status, headers, body) =
|
|
case preferRepresentation of
|
|
Just Full -> (upsertStatus, cLHeader ++ cTHeader ++ prefHeader, LBS.fromStrict rsBody)
|
|
Just None -> (HTTP.status204, prefHeader, mempty)
|
|
_ -> (HTTP.status204, prefHeader, mempty)
|
|
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers
|
|
|
|
Right $ PgrstResponse ovStatus ovHeaders body
|
|
|
|
actionResponse (DbCrudResult MutateReadPlan{mrMutation=MutationDelete, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} _ _ _ _ _ = do
|
|
let
|
|
contentRangeHeader = RangeQuery.contentRangeH 1 0 $ if shouldCount preferCount then Just rsQueryTotal else Nothing
|
|
prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing preferRepresentation preferCount preferTransaction Nothing preferHandling preferTimezone preferMaxAffected []
|
|
headers = contentRangeHeader : prefHeader
|
|
(status, headers', body) =
|
|
case preferRepresentation of
|
|
Just Full -> (HTTP.status200, headers ++ [contentLengthHeaderStrict rsBody] ++ contentTypeHeaders pMedia 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
|
|
|
|
actionResponse (DbCrudResult CallReadPlan{pMedia, crInvMthd=invMethod, crProc=proc} RSStandard {..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..},..} _ _ _ _ _ = do
|
|
let
|
|
(status, contentRange) =
|
|
RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
|
|
rsOrErrBody = if status == HTTP.status416
|
|
then Error.errorPayload $ Error.ApiRequestError $ Error.InvalidRange
|
|
$ Error.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
|
|
else LBS.fromStrict rsBody
|
|
isHeadMethod = invMethod == InvRead True
|
|
prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing Nothing preferCount preferTransaction Nothing preferHandling preferTimezone preferMaxAffected []
|
|
cLHeader = if isHeadMethod then mempty else [contentLengthHeaderLazy rsOrErrBody]
|
|
headers = contentRange : prefHeader
|
|
(status', headers', body) =
|
|
if Routine.funcReturnsVoid proc then
|
|
(HTTP.status204, headers, mempty)
|
|
else
|
|
(status,
|
|
headers ++ cLHeader ++ contentTypeHeaders pMedia ctxApiRequest,
|
|
if isHeadMethod then mempty else rsOrErrBody)
|
|
|
|
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status' headers'
|
|
|
|
Right $ PgrstResponse ovStatus ovHeaders body
|
|
|
|
actionResponse (DbPlanResult media plan) ctxApiRequest _ _ _ _ _ =
|
|
Right $ PgrstResponse HTTP.status200 (contentLengthHeaderStrict plan : contentTypeHeaders media ctxApiRequest) $ LBS.fromStrict plan
|
|
|
|
actionResponse (MaybeDbResult InspectPlan{ipHdrsOnly=headersOnly} body) _ versions conf sCache schema negotiatedByProfile =
|
|
let
|
|
rsBody = maybe mempty (\(x, y, z) -> if headersOnly then mempty else OpenAPI.encode versions conf sCache x y z) body
|
|
cLHeader = if headersOnly then mempty else [contentLengthHeaderLazy rsBody]
|
|
in
|
|
Right $ PgrstResponse HTTP.status200 (MediaType.toContentType MTOpenAPI : cLHeader ++ maybeToList (profileHeader schema negotiatedByProfile)) rsBody
|
|
|
|
actionResponse (NoDbResult (RelInfoPlan qi@QualifiedIdentifier{..})) _ _ _ SchemaCache{dbTables} _ _ =
|
|
case HM.lookup qi dbTables of
|
|
Just tbl -> respondInfo $ allowH tbl
|
|
Nothing -> Left $ Error.SchemaCacheErr $ Error.TableNotFound qiSchema qiName (HM.elems dbTables)
|
|
where
|
|
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]
|
|
|
|
actionResponse (NoDbResult (RoutineInfoPlan proc)) _ _ _ _ _ _
|
|
| pdVolatility proc == Volatile = respondInfo "OPTIONS,POST"
|
|
| otherwise = respondInfo "OPTIONS,GET,HEAD,POST"
|
|
|
|
actionResponse (NoDbResult SchemaInfoPlan) _ _ _ _ _ _ = respondInfo "OPTIONS,GET,HEAD"
|
|
|
|
respondInfo :: ByteString -> Either Error.Error PgrstResponse
|
|
respondInfo allowHeader =
|
|
let allOrigins = ("Access-Control-Allow-Origin", "*") in
|
|
Right $ PgrstResponse HTTP.status200 [contentLengthHeaderStrict mempty, allOrigins, (HTTP.hAllow, allowHeader)] mempty
|
|
|
|
-- Status and headers can be overridden as per https://postgrest.org/en/stable/references/transactions.html#response-headers
|
|
overrideStatusHeaders :: Maybe Text -> Maybe BS.ByteString -> HTTP.Status -> [HTTP.Header]-> Either Error.Error (HTTP.Status, [HTTP.Header])
|
|
overrideStatusHeaders rsGucStatus rsGucHeaders pgrstStatus pgrstHeaders = do
|
|
gucStatus <- decodeGucStatus rsGucStatus
|
|
gucHeaders <- decodeGucHeaders rsGucHeaders
|
|
Right (fromMaybe pgrstStatus gucStatus, addHeadersIfNotIncluded pgrstHeaders $ map unwrapGucHeader gucHeaders)
|
|
|
|
decodeGucHeaders :: Maybe BS.ByteString -> Either Error.Error [GucHeader]
|
|
decodeGucHeaders =
|
|
maybe (Right []) $ first (const . Error.ApiRequestError $ Error.GucHeadersError) . JSON.eitherDecode . LBS.fromStrict
|
|
|
|
decodeGucStatus :: Maybe Text -> Either Error.Error (Maybe HTTP.Status)
|
|
decodeGucStatus =
|
|
maybe (Right Nothing) $ first (const . Error.ApiRequestError $ Error.GucStatusError) . fmap (Just . toEnum . fst) . decimal
|
|
|
|
contentLengthHeader :: Show b => (a -> b) -> a -> HTTP.Header
|
|
contentLengthHeader lenFn body = ("Content-Length", show (lenFn body))
|
|
|
|
contentLengthHeaderStrict :: BS.ByteString -> HTTP.Header
|
|
contentLengthHeaderStrict = contentLengthHeader BS.length
|
|
|
|
contentLengthHeaderLazy :: LBS.ByteString -> HTTP.Header
|
|
contentLengthHeaderLazy = contentLengthHeader LBS.length
|
|
|
|
contentTypeHeaders :: MediaType -> ApiRequest -> [HTTP.Header]
|
|
contentTypeHeaders mediaType ApiRequest{..} =
|
|
MediaType.toContentType mediaType : maybeToList (profileHeader iSchema iNegotiatedByProfile)
|
|
|
|
profileHeader :: Schema -> Bool -> Maybe HTTP.Header
|
|
profileHeader schema negotiatedByProfile =
|
|
if negotiatedByProfile
|
|
then Just $ (,) "Content-Profile" (toS schema)
|
|
else
|
|
Nothing
|
|
|
|
-- | Add headers not already included to allow the user to override them instead of duplicating them
|
|
addHeadersIfNotIncluded :: [HTTP.Header] -> [HTTP.Header] -> [HTTP.Header]
|
|
addHeadersIfNotIncluded newHeaders initialHeaders =
|
|
filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
|
|
initialHeaders
|