refactor: move binaryField to ApiRequest

src/PostgREST/App.hs

@@ -20,7 +20,6 @@ module PostgREST.App
 
 import Control.Monad.Except     (liftEither)
 import Data.Either.Combinators  (mapLeft)
-import Data.List                (union)
 import Data.Maybe               (fromJust)
 import Data.String              (IsString (..))
 import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
@@ -58,15 +57,13 @@ import PostgREST.DbStructure.Identifiers (FieldName,
 import PostgREST.DbStructure.Proc        (ProcDescription (..))
 import PostgREST.DbStructure.Table       (Table (..))
 import PostgREST.Error                   (Error)
-import PostgREST.MediaType               (MTPlanAttrs (..),
-                                          MediaType (..))
 import PostgREST.Query                   (DbHandler)
 import PostgREST.Request.ApiRequest      (Action (..),
                                           ApiRequest (..),
                                           InvokeMethod (..),
                                           Mutation (..), Target (..))
 import PostgREST.Request.Preferences     (PreferRepresentation (..))
-import PostgREST.Request.ReadQuery       (ReadRequest, fstFieldNames)
+import PostgREST.Request.ReadQuery       (ReadRequest)
 import PostgREST.Version                 (prettyVersion)
 import PostgREST.Workers                 (connectionWorker, listener)
 
@@ -227,9 +224,8 @@ handleRequest context@(RequestContext _ _ ApiRequest{..} _) =
 handleRead :: Bool -> QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
 handleRead headersOnly identifier context@RequestContext{..} = do
   req <- liftEither $ readRequest identifier context
-  bField <- binaryField context req
 
-  (resultSet, total) <- Query.readQuery req ctxConfig ctxApiRequest bField
+  (resultSet, total) <- Query.readQuery req ctxConfig ctxApiRequest
 
   pure $ Response.readResponse headersOnly identifier ctxApiRequest total resultSet
 
@@ -275,10 +271,9 @@ handleInvoke invMethod proc context@RequestContext{..} = do
         (fromMaybe (pdName proc) $ Proc.procTableName proc)
 
   readReq <- liftEither $ readRequest identifier context
-  bField <- binaryField context readReq
   let callReq = ReqBuilder.callRequest proc ctxApiRequest readReq
 
-  resultSet <- Query.invokeQuery proc callReq readReq ctxApiRequest bField ctxConfig
+  resultSet <- Query.invokeQuery proc callReq readReq ctxApiRequest ctxConfig
 
   pure $ Response.invokeResponse invMethod proc ctxApiRequest resultSet
 
@@ -293,39 +288,8 @@ writeRequest mutation identifier@QualifiedIdentifier{..} context@RequestContext{
   mutateReq <- ReqBuilder.mutateRequest mutation qiSchema qiName ctxApiRequest pkCols readReq
   pure (mutateReq, readReq)
 
-returnsScalar :: ApiRequest.Target -> Bool
-returnsScalar (TargetProc proc _) = Proc.procReturnsScalar proc
-returnsScalar _                   = False
-
 readRequest :: QualifiedIdentifier -> RequestContext -> Either Error ReadRequest
 readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure apiRequest _) =
   ReqBuilder.readRequest qiSchema qiName configDbMaxRows
     (dbRelationships dbStructure)
     apiRequest
-
--- | If raw(binary) output is requested, check that MediaType is one of the
--- admitted rawMediaTypes and that`?select=...` contains only one field other
--- than `*`
-binaryField :: Monad m => RequestContext -> ReadRequest -> Handler m (Maybe FieldName)
-binaryField RequestContext{..} readReq
-  | returnsScalar (iTarget ctxApiRequest) && isRawMediaType =
-      return $ Just "pgrst_scalar"
-  | isRawMediaType =
-      let
-        fldNames = fstFieldNames readReq
-        fieldName = headMay fldNames
-      in
-      if length fldNames == 1 && fieldName /= Just "*" then
-        return fieldName
-      else
-        throwError $ Error.BinaryFieldError mediaType
-  | otherwise =
-      return Nothing
-  where
-    mediaType = iAcceptMediaType ctxApiRequest
-    isRawMediaType = mediaType `elem` configRawMediaTypes ctxConfig `union` [MTOctetStream, MTTextPlain, MTTextXML] || isRawPlan mediaType
-    isRawPlan mt = case mt of
-      MTPlan (MTPlanAttrs (Just MTOctetStream) _ _) -> True
-      MTPlan (MTPlanAttrs (Just MTTextPlain) _ _)   -> True
-      MTPlan (MTPlanAttrs (Just MTTextXML) _ _)     -> True
-      _                                             -> False

src/PostgREST/Error.hs

@@ -57,6 +57,7 @@ class (JSON.ToJSON a) => PgrstError a where
 instance PgrstError ApiRequestError where
   status AmbiguousRelBetween{}   = HTTP.status300
   status AmbiguousRpc{}          = HTTP.status300
+  status BinaryFieldError{}      = HTTP.status406
   status MediaTypeError{}        = HTTP.status415
   status InvalidBody{}           = HTTP.status400
   status InvalidFilters          = HTTP.status405
@@ -132,6 +133,12 @@ instance JSON.ToJSON ApiRequestError where
     "details" .= JSON.Null,
     "hint"    .= ("Apply an 'order' using unique column(s)" :: Text)]
 
+  toJSON (BinaryFieldError ct) = JSON.object [
+    "code"    .= ApiRequestErrorCode13,
+    "message" .= ((T.decodeUtf8 (MediaType.toMime ct) <> " requested but more than one column was selected") :: Text),
+    "details" .= JSON.Null,
+    "hint"    .= JSON.Null]
+
   toJSON PutRangeNotAllowedError = JSON.object [
     "code"    .= ApiRequestErrorCode14,
     "message" .= ("Range header and limit/offset querystring parameters are not allowed for PUT" :: Text),
@@ -333,7 +340,6 @@ checkIsFatal _ = Nothing
 
 data Error
   = ApiRequestError ApiRequestError
-  | BinaryFieldError MediaType
   | GucHeadersError
   | GucStatusError
   | JwtTokenInvalid Text
@@ -347,7 +353,6 @@ data Error
 
 instance PgrstError Error where
   status (ApiRequestError err)   = status err
-  status BinaryFieldError{}      = HTTP.status406
   status GucHeadersError         = HTTP.status500
   status GucStatusError          = HTTP.status500
   status JwtTokenInvalid{}       = HTTP.unauthorized401
@@ -405,11 +410,6 @@ instance JSON.ToJSON Error where
     "message" .= ("response.status guc must be a valid status code" :: Text),
     "details" .= JSON.Null,
     "hint"    .= JSON.Null]
-  toJSON (BinaryFieldError ct) = JSON.object [
-    "code"    .= ApiRequestErrorCode13,
-    "message" .= ((T.decodeUtf8 (MediaType.toMime ct) <> " requested but more than one column was selected") :: Text),
-    "details" .= JSON.Null,
-    "hint"    .= JSON.Null]
 
   toJSON PutMatchingPkError = JSON.object [
     "code"    .= ApiRequestErrorCode15,

src/PostgREST/Query.hs

@@ -67,8 +67,8 @@ import Protolude hiding (Handler)
 
 type DbHandler = ExceptT Error SQL.Transaction
 
-readQuery :: ReadRequest -> AppConfig -> ApiRequest -> Maybe FieldName -> DbHandler (ResultSet, Maybe Int64)
+readQuery :: ReadRequest -> AppConfig -> ApiRequest -> DbHandler (ResultSet, Maybe Int64)
-readQuery req conf@AppConfig{..} apiReq@ApiRequest{..} bField = do
+readQuery req conf@AppConfig{..} apiReq@ApiRequest{..} = do
   let countQuery = QueryBuilder.readRequestToCountQuery req
   resultSet <-
      lift . SQL.statement mempty $
@@ -82,7 +82,7 @@ readQuery req conf@AppConfig{..} apiReq@ApiRequest{..} bField = do
         )
         (shouldCount iPreferCount)
         iAcceptMediaType
-        bField
+        iBinaryField
         configDbPreparedStatements
   failNotSingular iAcceptMediaType resultSet
   total <- readTotal conf apiReq resultSet countQuery
@@ -144,8 +144,8 @@ deleteQuery mutateReq readReq apiReq@ApiRequest{..} conf = do
   failsChangesOffLimits (RangeQuery.rangeLimit iTopLevelRange) resultSet
   pure resultSet
 
-invokeQuery :: ProcDescription -> ApiRequestTypes.CallRequest -> ReadRequest -> ApiRequest -> Maybe FieldName -> AppConfig -> DbHandler ResultSet
+invokeQuery :: ProcDescription -> ApiRequestTypes.CallRequest -> ReadRequest -> ApiRequest -> AppConfig -> DbHandler ResultSet
-invokeQuery proc callReq readReq ApiRequest{..} bField AppConfig{..} = do
+invokeQuery proc callReq readReq ApiRequest{..} AppConfig{..} = do
   resultSet <-
     lift . SQL.statement mempty $
       Statements.prepareCall
@@ -157,7 +157,7 @@ invokeQuery proc callReq readReq ApiRequest{..} bField AppConfig{..} = do
         (shouldCount iPreferCount)
         iAcceptMediaType
         (iPreferParameters == Just MultipleObjects)
-        bField
+        iBinaryField
         configDbPreparedStatements
 
   failNotSingular iAcceptMediaType resultSet

src/PostgREST/Query/SqlFragment.hs

@@ -62,7 +62,6 @@ import PostgREST.MediaType               (MTPlanFormat (..),
                                           MTPlanOption (..))
 import PostgREST.RangeQuery              (NonnegRange, allRange,
                                           rangeLimit, rangeOffset)
-import PostgREST.Request.ReadQuery       (SelectItem)
 import PostgREST.Request.Types           (Alias, Field, Filter (..),
                                           FtsOperator (..),
                                           JoinCondition (..),
@@ -74,7 +73,7 @@ import PostgREST.Request.Types           (Alias, Field, Filter (..),
                                           Operation (..),
                                           OrderDirection (..),
                                           OrderNulls (..),
-                                          OrderTerm (..),
+                                          OrderTerm (..), SelectItem,
                                           SimpleOperator (..),
                                           TrileanVal (..))
 

src/PostgREST/Request/ApiRequest.hs

@@ -37,7 +37,8 @@ import Data.Aeson.Types          (emptyArray, emptyObject)
 import Data.List                 (lookup, union)
 import Data.Ranged.Ranges        (emptyRange, rangeIntersection,
                                   rangeIsEmpty)
-import Network.HTTP.Types.Header (hCookie, RequestHeaders)
+import Data.Tree                 (Tree (..))
+import Network.HTTP.Types.Header (RequestHeaders, hCookie)
 import Network.HTTP.Types.URI    (parseSimpleQuery)
 import Network.Wai               (Request (..))
 import Network.Wai.Parse         (parseHttpAccept)
@@ -50,7 +51,8 @@ import PostgREST.DbStructure.Identifiers (FieldName,
                                           QualifiedIdentifier (..),
                                           Schema)
 import PostgREST.DbStructure.Proc        (ProcDescription (..),
-                                          ProcParam (..), ProcsMap)
+                                          ProcParam (..), ProcsMap,
+                                          procReturnsScalar)
 import PostgREST.MediaType               (MTPlanAttrs (..),
                                           MTPlanFormat (..),
                                           MediaType (..))
@@ -65,7 +67,7 @@ import PostgREST.Request.Preferences     (PreferCount (..),
                                           PreferTransaction (..))
 import PostgREST.Request.QueryParams     (QueryParams (..))
 import PostgREST.Request.Types           (ApiRequestError (..),
-                                          RangeError (..))
+                                          RangeError (..), SelectItem)
 
 import qualified PostgREST.MediaType           as MediaType
 import qualified PostgREST.Request.Preferences as Preferences
@@ -172,7 +174,8 @@ data ApiRequest = ApiRequest {
   , iMethod               :: ByteString                       -- ^ Raw request method
   , iSchema               :: Schema                           -- ^ The request schema. Can vary depending on profile headers.
   , iNegotiatedByProfile  :: Bool                             -- ^ If schema was was chosen according to the profile spec https://www.w3.org/TR/dx-prof-conneg/
-  , iAcceptMediaType      :: MediaType
+  , iAcceptMediaType      :: MediaType                        -- ^ The media type in the Accept header
+  , iBinaryField          :: Maybe FieldName                  -- ^ field used for raw output
   }
 
 -- | Examines HTTP request and translates it into user intent.
@@ -183,7 +186,7 @@ userApiRequest conf dbStructure req reqBody = do
   act <- getAction pInfo $ requestMethod req
   mediaTypes <- getMediaTypes conf (requestHeaders req) act pInfo
   negotiatedSchema <- getSchema conf (requestHeaders req) (requestMethod req)
-  apiRequest dbStructure req reqBody qPrms pInfo act mediaTypes negotiatedSchema
+  apiRequest conf dbStructure req reqBody qPrms pInfo act mediaTypes negotiatedSchema
 
 getPathInfo :: AppConfig -> [Text] -> Either ApiRequestError PathInfo
 getPathInfo AppConfig{configOpenApiMode, configDbRootSpec} path =
@@ -220,7 +223,7 @@ getAction PathInfo{pathIsProc, pathIsDefSpec} method =
 getMediaTypes :: AppConfig -> RequestHeaders -> Action -> PathInfo -> Either ApiRequestError (MediaType, MediaType)
 getMediaTypes conf hdrs action path = do
    acceptMediaType <- findAcceptMediaType conf action path accepts
-   pure $ (acceptMediaType, contentMediaType)
+   pure (acceptMediaType, contentMediaType)
   where
     accepts = maybe [MTAny] (map MediaType.decodeMediaType . parseHttpAccept) $ lookupHeader "accept"
     contentMediaType = maybe MTApplicationJSON MediaType.decodeMediaType $ lookupHeader "content-type"
@@ -245,8 +248,8 @@ getSchema AppConfig{configDbSchemas} hdrs method = do
     acceptProfile = T.decodeUtf8 <$> lookupHeader "Accept-Profile"
     lookupHeader    = flip lookup hdrs
 
-apiRequest :: DbStructure -> Request -> RequestBody -> QueryParams.QueryParams -> PathInfo -> Action -> (MediaType, MediaType) -> (Schema, Bool) -> Either ApiRequestError ApiRequest
+apiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> QueryParams.QueryParams -> PathInfo -> Action -> (MediaType, MediaType) -> (Schema, Bool) -> Either ApiRequestError ApiRequest
-apiRequest dbStructure req reqBody queryparams@QueryParams{..} PathInfo{pathName, pathIsProc, pathIsRootSpec, pathIsDefSpec} action (acceptMediaType, contentMediaType) (schema, negotiatedByProfile)
+apiRequest conf dbStructure req reqBody queryparams@QueryParams{..} PathInfo{pathName, pathIsProc, pathIsRootSpec, pathIsDefSpec} action (acceptMediaType, contentMediaType) (schema, negotiatedByProfile)
   | isInvalidRange = Left $ InvalidRange (if rangeIsEmpty headerRange then LowerGTUpper else NegativeLimit)
   | shouldParsePayload && isLeft payload = either (Left . InvalidBody) witness payload
   | not expectParams && not (L.null qsParams) = Left $ ParseRequestError "Unexpected param or filter missing operator" ("Failed to parse " <> show qsParams)
@@ -254,6 +257,7 @@ apiRequest dbStructure req reqBody queryparams@QueryParams{..} PathInfo{pathName
   | method == "PUT" && topLevelRange /= allRange = Left PutRangeNotAllowedError
   | otherwise = do
      checkedTarget <- target
+     bField <- binaryField conf acceptMediaType checkedTarget queryparams
      return ApiRequest {
       iAction = action
       , iTarget = checkedTarget
@@ -274,6 +278,7 @@ apiRequest dbStructure req reqBody queryparams@QueryParams{..} PathInfo{pathName
       , iSchema = schema
       , iNegotiatedByProfile = negotiatedByProfile
       , iAcceptMediaType = acceptMediaType
+      , iBinaryField = bField
       }
  where
   expectParams = pathIsProc && method /= "POST"
@@ -494,3 +499,35 @@ findProc qi argumentsKeys paramsAsSingleObject allProcs contentMediaType isInvPo
       -- If the function has required and optional parameters, the arguments keys have to match the required parameters
       -- and can match any or none of the default parameters.
         (reqParams, optParams) -> argumentsKeys `S.difference` S.fromList (ppName <$> optParams) == S.fromList (ppName <$> reqParams)
+
+-- | If raw(binary) output is requested, check that MediaType is one of the
+-- admitted rawMediaTypes and that`?select=...` contains only one field other
+-- than `*`
+binaryField :: AppConfig -> MediaType -> Target -> QueryParams -> Either ApiRequestError (Maybe FieldName)
+binaryField AppConfig{configRawMediaTypes} acceptMediaType target QueryParams{qsSelect}
+  | returnsScalar target && isRawMediaType =
+      Right $ Just "pgrst_scalar"
+  | isRawMediaType =
+      let
+        fieldName = fstFieldName qsSelect
+      in
+      case fieldName of
+        Just fld -> Right $ Just fld
+        Nothing  -> Left $ BinaryFieldError acceptMediaType
+  | otherwise =
+      Right Nothing
+  where
+    isRawMediaType = acceptMediaType `elem` configRawMediaTypes `union` [MTOctetStream, MTTextPlain, MTTextXML] || isRawPlan acceptMediaType
+    isRawPlan mt = case mt of
+      MTPlan (MTPlanAttrs (Just MTOctetStream) _ _) -> True
+      MTPlan (MTPlanAttrs (Just MTTextPlain) _ _)   -> True
+      MTPlan (MTPlanAttrs (Just MTTextXML) _ _)     -> True
+      _                                             -> False
+    returnsScalar :: Target -> Bool
+    returnsScalar (TargetProc proc _) = procReturnsScalar proc
+    returnsScalar _                   = False
+
+    fstFieldName :: [Tree SelectItem] -> Maybe FieldName
+    fstFieldName [Node (("*", _), Nothing, Nothing, Nothing, Nothing) []] = Nothing
+    fstFieldName [Node ((fld, _), Nothing, Nothing, Nothing, Nothing) []] = Just fld
+    fstFieldName _                           = Nothing

src/PostgREST/Request/QueryParams.hs

@@ -44,17 +44,15 @@ import PostgREST.RangeQuery              (NonnegRange, allRange,
                                           rangeGeq, rangeLimit,
                                           rangeOffset, restrictRange)
 
-import PostgREST.Request.ReadQuery (SelectItem)
 import PostgREST.Request.Types (EmbedParam (..), EmbedPath, Field,
                                 Filter (..), FtsOperator (..),
                                 JoinType (..), JsonOperand (..),
-                                    JsonOperation (..), JsonPath,
+                                JsonOperation (..), JsonPath, ListVal,
-                                    ListVal, LogicOperator (..),
+                                LogicOperator (..), LogicTree (..),
-                                    LogicTree (..), OpExpr (..),
+                                OpExpr (..), Operation (..),
-                                    Operation (..),
+                                OrderDirection (..), OrderNulls (..),
-                                    OrderDirection (..),
+                                OrderTerm (..), QPError (..),
-                                    OrderNulls (..), OrderTerm (..),
+                                SelectItem, SimpleOperator (..),
-                                    QPError (..), SimpleOperator (..),
                                 SingleVal, TrileanVal (..))
 
 import Protolude hiding (try)

src/PostgREST/Request/ReadQuery.hs

@@ -2,7 +2,6 @@ module PostgREST.Request.ReadQuery
   ( ReadNode
   , ReadQuery(..)
   , ReadRequest
-  , SelectItem
   , fstFieldNames
   ) where
 
@@ -12,10 +11,10 @@ import PostgREST.DbStructure.Identifiers  (FieldName,
                                            QualifiedIdentifier)
 import PostgREST.DbStructure.Relationship (Relationship)
 import PostgREST.RangeQuery               (NonnegRange)
-import PostgREST.Request.Types            (Alias, Cast, Depth, Field,
+import PostgREST.Request.Types            (Alias, Depth, Hint,
-                                           Hint, JoinCondition,
+                                           JoinCondition, JoinType,
-                                           JoinType, LogicTree,
+                                           LogicTree, NodeName,
-                                           NodeName, OrderTerm)
+                                           OrderTerm, SelectItem)
 
 
 import Protolude
@@ -25,9 +24,6 @@ type ReadRequest = Tree ReadNode
 type ReadNode =
   (ReadQuery, (NodeName, Maybe Relationship, Maybe Alias, Maybe Hint, Maybe JoinType, Depth))
 
--- | The select value in `/tbl?select=alias:field::cast`
-type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe Hint, Maybe JoinType)
-
 data ReadQuery = Select
   { select         :: [SelectItem]
   , from           :: QualifiedIdentifier

src/PostgREST/Request/Types.hs

@@ -32,6 +32,7 @@ module PostgREST.Request.Types
   , TrileanVal(..)
   , SimpleOperator(..)
   , FtsOperator(..)
+  , SelectItem
   ) where
 
 import qualified Data.ByteString.Lazy as LBS
@@ -45,11 +46,13 @@ import PostgREST.MediaType                (MediaType (..))
 
 import Protolude
 
-
+-- | The select value in `/tbl?select=alias:field::cast`
+type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe Hint, Maybe JoinType)
 
 data ApiRequestError
   = AmbiguousRelBetween Text Text [Relationship]
   | AmbiguousRpc [ProcDescription]
+  | BinaryFieldError MediaType
   | MediaTypeError [ByteString]
   | InvalidBody ByteString
   | InvalidFilters