jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor: move guc headers/status decoding to App

Browse Source
This commit is contained in:
steve-chavez
2022-09-25 13:53:11 -05:00
committed by Steve Chavez
parent 9d3bbc736b
commit c27e7be028
2 changed files with 33 additions and 36 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+27 -17
View File
@@ -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
src/PostgREST/Query/Statements.hs
+6 -19
View File
@@ -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