diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 17bf4a16a..a26ae85b1 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 d8ba389ff..41851e17a 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