refactor: add iPreferences to ApiRequest

It avoids adding a new iPrefer.. to the ApiRequest every time a
preference is added.

src/PostgREST/ApiRequest.hs

@@ -46,11 +46,6 @@ import Network.Wai               (Request (..))
 import Network.Wai.Parse         (parseHttpAccept)
 import Web.Cookie                (parseCookies)
 
-import PostgREST.ApiRequest.Preferences  (PreferCount (..),
-                                          PreferParameters (..),
-                                          PreferRepresentation (..),
-                                          PreferResolution (..),
-                                          PreferTransaction (..))
 import PostgREST.ApiRequest.QueryParams  (QueryParams (..))
 import PostgREST.ApiRequest.Types        (ApiRequestError (..),
                                           RangeError (..))
@@ -123,26 +118,22 @@ data Target = TargetIdent QualifiedIdentifier
   if it is an action we are able to perform.
 -}
 data ApiRequest = ApiRequest {
-    iAction               :: Action                           -- ^ Similar but not identical to HTTP method, e.g. Create/Invoke both POST
+    iAction              :: Action                           -- ^ Similar but not identical to HTTP method, e.g. Create/Invoke both POST
-  , iRange                :: HM.HashMap Text NonnegRange      -- ^ Requested range of rows within response
+  , iRange               :: HM.HashMap Text NonnegRange      -- ^ Requested range of rows within response
-  , iTopLevelRange        :: NonnegRange                      -- ^ Requested range of rows from the top level
+  , iTopLevelRange       :: NonnegRange                      -- ^ Requested range of rows from the top level
-  , iTarget               :: Target                           -- ^ The target, be it calling a proc or accessing a table
+  , iTarget              :: Target                           -- ^ The target, be it calling a proc or accessing a table
-  , iPayload              :: Maybe Payload                    -- ^ Data sent by client and used for mutation actions
+  , iPayload             :: Maybe Payload                    -- ^ Data sent by client and used for mutation actions
-  , iPreferRepresentation :: PreferRepresentation             -- ^ If client wants created items echoed back
+  , iPreferences         :: Preferences.Preferences          -- ^ Prefer header values
-  , iPreferParameters     :: Maybe PreferParameters           -- ^ How to pass parameters to a stored procedure
+  , iQueryParams         :: QueryParams.QueryParams
-  , iPreferCount          :: Maybe PreferCount                -- ^ Whether the client wants a result count
+  , iColumns             :: S.Set FieldName                  -- ^ parsed colums from &columns parameter and payload
-  , iPreferResolution     :: Maybe PreferResolution           -- ^ Whether the client wants to UPSERT or ignore records on PK conflict
+  , iHeaders             :: [(ByteString, ByteString)]       -- ^ HTTP request headers
-  , iPreferTransaction    :: Maybe PreferTransaction          -- ^ Whether the clients wants to commit or rollback the transaction
+  , iCookies             :: [(ByteString, ByteString)]       -- ^ Request Cookies
-  , iQueryParams          :: QueryParams.QueryParams
+  , iPath                :: ByteString                       -- ^ Raw request path
-  , iColumns              :: S.Set FieldName                  -- ^ parsed colums from &columns parameter and payload
+  , iMethod              :: ByteString                       -- ^ Raw request method
-  , iHeaders              :: [(ByteString, ByteString)]       -- ^ HTTP request headers
+  , iSchema              :: Schema                           -- ^ The request schema. Can vary depending on profile headers.
-  , iCookies              :: [(ByteString, ByteString)]       -- ^ Request Cookies
+  , iNegotiatedByProfile :: Bool                             -- ^ If schema was was chosen according to the profile spec https://www.w3.org/TR/dx-prof-conneg/
-  , iPath                 :: ByteString                       -- ^ Raw request path
+  , iAcceptMediaType     :: MediaType                        -- ^ The media type in the Accept header
-  , iMethod               :: ByteString                       -- ^ Raw request method
+  , iContentMediaType    :: MediaType                        -- ^ The media type in the Content-Type header
-  , 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                        -- ^ The media type in the Accept header
-  , iContentMediaType     :: MediaType                        -- ^ The media type in the Content-Type header
   }
 
 -- | Examines HTTP request and translates it into user intent.
@@ -163,11 +154,7 @@ userApiRequest conf req reqBody = do
   , iRange = ranges
   , iTopLevelRange = topLevelRange
   , iPayload = payload
-  , iPreferRepresentation = fromMaybe None preferRepresentation
+  , iPreferences = Preferences.fromHeaders hdrs
-  , iPreferParameters = preferParameters
-  , iPreferCount = preferCount
-  , iPreferResolution = preferResolution
-  , iPreferTransaction = preferTransaction
   , iQueryParams = qPrms
   , iColumns = columns
   , iHeaders = iHdrs
@@ -183,7 +170,6 @@ userApiRequest conf req reqBody = do
     method = requestMethod req
     hdrs = requestHeaders req
     lookupHeader    = flip lookup hdrs
-    Preferences.Preferences{..} = Preferences.fromHeaders hdrs
     iHdrs = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie]
     iCkies = maybe [] parseCookies $ lookupHeader "Cookie"
 

src/PostgREST/ApiRequest/Preferences.hs

@@ -39,7 +39,7 @@ import Protolude
 data Preferences
   = Preferences
     { preferResolution     :: Maybe PreferResolution
-    , preferRepresentation :: Maybe PreferRepresentation
+    , preferRepresentation :: PreferRepresentation
     , preferParameters     :: Maybe PreferParameters
     , preferCount          :: Maybe PreferCount
     , preferTransaction    :: Maybe PreferTransaction
@@ -53,7 +53,7 @@ data Preferences
 -- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates, count=exact")]
 -- Preferences
 --     { preferResolution = Just IgnoreDuplicates
---     , preferRepresentation = Nothing
+--     , preferRepresentation = None
 --     , preferParameters = Nothing
 --     , preferCount = Just ExactCount
 --     , preferTransaction = Nothing
@@ -64,7 +64,7 @@ data Preferences
 -- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates"), ("Prefer", "count=exact")]
 -- Preferences
 --     { preferResolution = Just IgnoreDuplicates
---     , preferRepresentation = Nothing
+--     , preferRepresentation = None
 --     , preferParameters = Nothing
 --     , preferCount = Just ExactCount
 --     , preferTransaction = Nothing
@@ -92,10 +92,10 @@ data Preferences
 --
 -- Preferences can be separated by arbitrary amounts of space, lower-case header is also recognized:
 --
--- >>> pPrint $ fromHeaders [("prefer", "count=exact,    tx=commit   ,return=minimal")]
+-- >>> pPrint $ fromHeaders [("prefer", "count=exact,    tx=commit   ,return=representation")]
 -- Preferences
 --     { preferResolution = Nothing
---     , preferRepresentation = Just None
+--     , preferRepresentation = Full
 --     , preferParameters = Nothing
 --     , preferCount = Just ExactCount
 --     , preferTransaction = Just Commit
@@ -105,7 +105,7 @@ fromHeaders :: [HTTP.Header] -> Preferences
 fromHeaders headers =
   Preferences
     { preferResolution = parsePrefs [MergeDuplicates, IgnoreDuplicates]
-    , preferRepresentation = parsePrefs [Full, None, HeadersOnly]
+    , preferRepresentation = fromMaybe None $ parsePrefs [Full, None, HeadersOnly]
     , preferParameters = parsePrefs [SingleObject, MultipleObjects]
     , preferCount = parsePrefs [ExactCount, PlannedCount, EstimatedCount]
     , preferTransaction = parsePrefs [Commit, Rollback]

src/PostgREST/Plan.hs

@@ -115,7 +115,7 @@ callReadPlan identifier conf sCache apiRequest invMethod = do
         InvHead -> S.fromList $ fst <$> qsParams'
         InvPost -> iColumns apiRequest
   proc@ProcDescription{..} <- mapLeft ApiRequestError $
-    findProc identifier paramKeys (iPreferParameters apiRequest == Just SingleObject) (dbProcs sCache) (iContentMediaType apiRequest) (invMethod == InvPost)
+    findProc identifier paramKeys (preferParameters == Just SingleObject) (dbProcs sCache) (iContentMediaType apiRequest) (invMethod == InvPost)
   let relIdentifier = QualifiedIdentifier pdSchema (fromMaybe pdName $ Proc.procTableName proc) -- done so a set returning function can embed other relations
   rPlan <- readPlan relIdentifier conf sCache apiRequest
   let args = case (invMethod, iContentMediaType apiRequest) of
@@ -133,6 +133,7 @@ callReadPlan identifier conf sCache apiRequest invMethod = do
   binField <- mapLeft ApiRequestError $ binaryField conf (iAcceptMediaType apiRequest) (Just proc) rPlan
   return $ CallReadPlan rPlan cPlan txMode proc binField
   where
+    Preferences{..} = iPreferences apiRequest
     qsParams' = QueryParams.qsParams (iQueryParams apiRequest)
 
 {-|
@@ -500,10 +501,10 @@ updateNode f (targetNodeName:remainingPath, a) (Right (Node rootNode forest)) =
     findNode = find (\(Node ReadPlan{relName, relAlias} _) -> relName == targetNodeName || relAlias == Just targetNodeName) forest
 
 mutatePlan :: Mutation -> QualifiedIdentifier -> ApiRequest -> SchemaCache -> ReadPlanTree -> Either Error MutatePlan
-mutatePlan mutation qi ApiRequest{..} sCache readReq = mapLeft ApiRequestError $
+mutatePlan mutation qi ApiRequest{iPreferences=Preferences{..}, ..} sCache readReq = mapLeft ApiRequestError $
   case mutation of
     MutationCreate ->
-      mapRight (\typedColumns -> Insert qi typedColumns body ((,) <$> iPreferResolution <*> Just confCols) [] returnings pkCols) typedColumnsOrError
+      mapRight (\typedColumns -> Insert qi typedColumns body ((,) <$> preferResolution <*> Just confCols) [] returnings pkCols) typedColumnsOrError
     MutationUpdate ->
       mapRight (\typedColumns -> Update qi typedColumns body combinedLogic iTopLevelRange rootOrder returnings) typedColumnsOrError
     MutationSingleUpsert ->
@@ -521,7 +522,7 @@ mutatePlan mutation qi ApiRequest{..} sCache readReq = mapLeft ApiRequestError $
     confCols = fromMaybe pkCols qsOnConflict
     QueryParams.QueryParams{..} = iQueryParams
     returnings =
-      if iPreferRepresentation == None
+      if preferRepresentation == None
         then []
         else inferColsEmbedNeeds readReq pkCols
     pkCols = maybe mempty tablePKCols $ HM.lookup qi $ dbTables sCache
@@ -540,16 +541,16 @@ resolveOrError (Just table) field =
     Just typedField -> Right typedField
 
 callPlan :: ProcDescription -> ApiRequest -> S.Set FieldName -> LBS.ByteString -> ReadPlanTree -> CallPlan
-callPlan proc apiReq paramKeys args readReq = FunctionCall {
+callPlan proc ApiRequest{iPreferences=Preferences{..}} paramKeys args readReq = FunctionCall {
   funCQi = QualifiedIdentifier (pdSchema proc) (pdName proc)
 , funCParams = callParams
 , funCArgs = Just args
 , funCScalar = procReturnsScalar proc
-, funCMultipleCall = iPreferParameters apiReq == Just MultipleObjects
+, funCMultipleCall = preferParameters == Just MultipleObjects
 , funCReturning = inferColsEmbedNeeds readReq []
 }
   where
-    paramsAsSingleObject = iPreferParameters apiReq == Just SingleObject
+    paramsAsSingleObject = preferParameters == Just SingleObject
     specifiedParams = filter (\x -> ppName x `S.member` paramKeys)
     callParams = case pdParams proc of
       [prm] | paramsAsSingleObject -> OnePosParam prm

src/PostgREST/Query.hs

@@ -38,6 +38,7 @@ import PostgREST.ApiRequest              (ApiRequest (..))
 import PostgREST.ApiRequest.Preferences  (PreferCount (..),
                                           PreferParameters (..),
                                           PreferTransaction (..),
+                                          Preferences (..),
                                           shouldCount)
 import PostgREST.Config                  (AppConfig (..),
                                           OpenAPIMode (..))
@@ -66,19 +67,19 @@ import Protolude hiding (Handler)
 type DbHandler = ExceptT Error SQL.Transaction
 
 readQuery :: WrappedReadPlan -> AppConfig -> ApiRequest -> DbHandler ResultSet
-readQuery WrappedReadPlan{wrReadPlan, wrBinField} conf@AppConfig{..} apiReq@ApiRequest{..} = do
+readQuery WrappedReadPlan{wrReadPlan, wrBinField} conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}, ..} = do
   let countQuery = QueryBuilder.readPlanToCountQuery wrReadPlan
   resultSet <-
      lift . SQL.statement mempty $
       Statements.prepareRead
         (QueryBuilder.readPlanToQuery wrReadPlan)
-        (if iPreferCount == Just EstimatedCount then
+        (if preferCount == Just EstimatedCount then
            -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed
            QueryBuilder.limitedQuery countQuery ((+ 1) <$> configDbMaxRows)
          else
            countQuery
         )
-        (shouldCount iPreferCount)
+        (shouldCount preferCount)
         iAcceptMediaType
         wrBinField
         configDbPreparedStatements
@@ -88,8 +89,8 @@ readQuery WrappedReadPlan{wrReadPlan, wrBinField} conf@AppConfig{..} apiReq@ApiR
 
 resultSetWTotal :: AppConfig -> ApiRequest -> ResultSet -> SQL.Snippet -> DbHandler ResultSet
 resultSetWTotal _ _ rs@RSPlan{} _ = return rs
-resultSetWTotal AppConfig{..} ApiRequest{..} rs@RSStandard{rsTableTotal=tableTotal} countQuery =
+resultSetWTotal AppConfig{..} ApiRequest{iPreferences=Preferences{..}} rs@RSStandard{rsTableTotal=tableTotal} countQuery =
-  case iPreferCount of
+  case preferCount of
     Just PlannedCount -> do
       total <- explain
       return rs{rsTableTotal=total}
@@ -151,7 +152,7 @@ deleteQuery mrPlan apiReq@ApiRequest{..} conf = do
   pure resultSet
 
 invokeQuery :: ProcDescription -> CallReadPlan -> ApiRequest -> AppConfig -> DbHandler ResultSet
-invokeQuery proc CallReadPlan{crReadPlan, crCallPlan, crBinField} apiReq@ApiRequest{..} conf@AppConfig{..} = do
+invokeQuery proc CallReadPlan{crReadPlan, crCallPlan, crBinField} apiReq@ApiRequest{iPreferences=Preferences{..}, ..} conf@AppConfig{..} = do
   resultSet <-
     lift . SQL.statement mempty $
       Statements.prepareCall
@@ -160,9 +161,9 @@ invokeQuery proc CallReadPlan{crReadPlan, crCallPlan, crBinField} apiReq@ApiRequ
         (QueryBuilder.callPlanToQuery crCallPlan)
         (QueryBuilder.readPlanToQuery crReadPlan)
         (QueryBuilder.readPlanToCountQuery crReadPlan)
-        (shouldCount iPreferCount)
+        (shouldCount preferCount)
         iAcceptMediaType
-        (iPreferParameters == Just MultipleObjects)
+        (preferParameters == Just MultipleObjects)
         crBinField
         configDbPreparedStatements
 
@@ -188,7 +189,7 @@ openApiQuery sCache pgVer AppConfig{..} tSchema =
       pure Nothing
 
 writeQuery :: MutateReadPlan -> ApiRequest -> AppConfig  -> DbHandler ResultSet
-writeQuery MutateReadPlan{mrReadPlan, mrMutatePlan} apiReq conf =
+writeQuery MutateReadPlan{mrReadPlan, mrMutatePlan} apiReq@ApiRequest{iPreferences=Preferences{..}} conf =
   let
     (isInsert, pkCols) = case mrMutatePlan of {Insert{insPkCols} -> (True, insPkCols); _ -> (False, mempty);}
   in
@@ -198,7 +199,7 @@ writeQuery MutateReadPlan{mrReadPlan, mrMutatePlan} apiReq conf =
       (QueryBuilder.mutatePlanToQuery mrMutatePlan)
       isInsert
       (iAcceptMediaType apiReq)
-      (iPreferRepresentation apiReq)
+      preferRepresentation
       pkCols
       (configDbPreparedStatements conf)
 
@@ -222,15 +223,15 @@ failsChangesOffLimits (Just maxChanges) RSStandard{rsQueryTotal=queryTotal} =
 
 -- | Set a transaction to roll back if requested
 optionalRollback :: AppConfig -> ApiRequest -> DbHandler ()
-optionalRollback AppConfig{..} ApiRequest{..} = do
+optionalRollback AppConfig{..} ApiRequest{iPreferences=Preferences{..}} = do
   lift $ when (shouldRollback || (configDbTxRollbackAll && not shouldCommit)) $ do
     SQL.sql "SET CONSTRAINTS ALL IMMEDIATE"
     SQL.condemn
   where
     shouldCommit =
-      configDbTxAllowOverride && iPreferTransaction == Just Commit
+      configDbTxAllowOverride && preferTransaction == Just Commit
     shouldRollback =
-      configDbTxAllowOverride && iPreferTransaction == Just Rollback
+      configDbTxAllowOverride && preferTransaction == Just Rollback
 
 -- | Runs local (transaction scoped) GUCs for every request.
 setPgLocals :: AppConfig  -> KM.KeyMap JSON.Value -> Text ->

src/PostgREST/Response.hs

@@ -37,6 +37,7 @@ import PostgREST.ApiRequest              (ApiRequest (..),
                                           InvokeMethod (..))
 import PostgREST.ApiRequest.Preferences  (PreferRepresentation (..),
                                           PreferTransaction (..),
+                                          Preferences (..),
                                           shouldCount,
                                           toAppliedHeader)
 import PostgREST.ApiRequest.QueryParams  (QueryParams (..))
@@ -86,7 +87,7 @@ readResponse headersOnly identifier ctxApiRequest@ApiRequest{..} resultSet = cas
     Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
 
 createResponse :: QualifiedIdentifier -> MutateReadPlan -> ApiRequest -> ResultSet -> Wai.Response
-createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan} ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}, ..} resultSet = case resultSet of
   RSStandard{..} -> do
     let
       pkCols = case mrMutatePlan of { Insert{insPkCols} -> insPkCols; _ -> mempty;}
@@ -103,14 +104,14 @@ createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan} ctxApiReques
                     <> HTTP.renderSimpleQuery True rsLocation
                 )
           , Just . RangeQuery.contentRangeH 1 0 $
-              if shouldCount iPreferCount then Just rsQueryTotal else Nothing
+              if shouldCount preferCount then Just rsQueryTotal else Nothing
           , if null pkCols && isNothing (qsOnConflict iQueryParams) then
               Nothing
             else
-              toAppliedHeader <$> iPreferResolution
+              toAppliedHeader <$> preferResolution
           ]
 
-    if iPreferRepresentation == Full then
+    if preferRepresentation == Full then
       response HTTP.status201 (headers ++ contentTypeHeaders ctxApiRequest) (LBS.fromStrict rsBody)
     else
       response HTTP.status201 headers mempty
@@ -119,16 +120,16 @@ createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan} ctxApiReques
     Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
 
 updateResponse :: ApiRequest -> ResultSet -> Wai.Response
-updateResponse ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+updateResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet = case resultSet of
   RSStandard{..} -> do
     let
       response = gucResponse rsGucStatus rsGucHeaders
       contentRangeHeader =
         RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
-          if shouldCount iPreferCount then Just rsQueryTotal else Nothing
+          if shouldCount preferCount then Just rsQueryTotal else Nothing
       headers = [contentRangeHeader]
 
-    if iPreferRepresentation == Full then
+    if preferRepresentation == Full then
         response HTTP.status200
           (headers ++ contentTypeHeaders ctxApiRequest)
           (LBS.fromStrict rsBody)
@@ -139,12 +140,12 @@ updateResponse ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
     Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
 
 singleUpsertResponse :: ApiRequest -> ResultSet -> Wai.Response
-singleUpsertResponse ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+singleUpsertResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet = case resultSet of
   RSStandard {..} -> do
     let
       response = gucResponse rsGucStatus rsGucHeaders
 
-    if iPreferRepresentation == Full then
+    if preferRepresentation == Full then
       response HTTP.status200 (contentTypeHeaders ctxApiRequest) (LBS.fromStrict rsBody)
     else
       response HTTP.status204 [] mempty
@@ -153,16 +154,16 @@ singleUpsertResponse ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
     Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
 
 deleteResponse :: ApiRequest -> ResultSet -> Wai.Response
-deleteResponse ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+deleteResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet = case resultSet of
   RSStandard {..} -> do
     let
       response = gucResponse rsGucStatus rsGucHeaders
       contentRangeHeader =
         RangeQuery.contentRangeH 1 0 $
-          if shouldCount iPreferCount then Just rsQueryTotal else Nothing
+          if shouldCount preferCount then Just rsQueryTotal else Nothing
       headers = [contentRangeHeader]
 
-    if iPreferRepresentation == Full then
+    if preferRepresentation == Full then
         response HTTP.status200
           (headers ++ contentTypeHeaders ctxApiRequest)
           (LBS.fromStrict rsBody)
@@ -270,14 +271,14 @@ isServiceUnavailable :: Wai.Response -> Bool
 isServiceUnavailable response = Wai.responseStatus response == HTTP.status503
 
 optionalRollback :: AppConfig -> ApiRequest -> ExceptT Error.Error IO Wai.Response -> ExceptT Error.Error IO Wai.Response
-optionalRollback AppConfig{..} ApiRequest{..} resp = do
+optionalRollback AppConfig{..} ApiRequest{iPreferences=Preferences{..}} resp = do
   newRes <- catchError resp $ return . Error.errorResponseFor
   return $ Wai.mapResponseHeaders preferenceApplied newRes
   where
     shouldCommit =
-      configDbTxAllowOverride && iPreferTransaction == Just Commit
+      configDbTxAllowOverride && preferTransaction == Just Commit
     shouldRollback =
-      configDbTxAllowOverride && iPreferTransaction == Just Rollback
+      configDbTxAllowOverride && preferTransaction == Just Rollback
     preferenceApplied
       | shouldCommit =
           addHeadersIfNotIncluded