refactor: move guc headers/status decoding to App

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
-
+      let
-      response <- liftEither $ gucResponse <$> rsGucStatus <*> rsGucHeaders
+        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
+  :: Maybe Text
-  -> [GucHeader]
+  -> Maybe BS.ByteString
   -> HTTP.Status
   -> [HTTP.Header]
   -> LBS.ByteString
   -> Wai.Response
-gucResponse gucStatus gucHeaders status headers =
+gucResponse rsGucStatus rsGucHeaders status headers body =
-  Wai.responseLBS (fromMaybe status gucStatus) $
+  case (,) <$> decodeGucStatus rsGucStatus <*> decodeGucHeaders rsGucHeaders of
-    addHeadersIfNotIncluded headers (map unwrapGucHeader gucHeaders)
+    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

@@ -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)
+             <*> nullableColumn HD.bytea
-             <*> (fromMaybe (Right Nothing) <$> nullableColumn decodeGucStatus)
+             <*> 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