fix: HEAD unnecessarily executing aggregates

CHANGELOG.md

@@ -27,6 +27,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
  - #2821, Fix OPTIONS not accepting all available media types - @steve-chavez
  - #2834, Fix compilation on Ubuntu by being compatible with GHC 9.0.2 - @steve-chavez
  - #2840, Fix `Prefer: missing=default` with DOMAIN default values - @steve-chavez
+ - #2849, Fix HEAD unnecessarily executing aggregates - @steve-chavez
 
 ## [11.1.0] - 2023-06-07
 

src/PostgREST/MediaType.hs

@@ -7,7 +7,6 @@ module PostgREST.MediaType
  , toContentType
  , toMime
  , decodeMediaType
- , getMediaType
  ) where
 
 import qualified Data.ByteString as BS
@@ -30,6 +29,7 @@ data MediaType
  | MTOctetStream
  | MTAny
  | MTOther ByteString
+ -- TODO MTPlan should only have its options as [Text]. Its ResultAggregate should have the typed attributes.
  | MTPlan MediaType MTPlanFormat [MTPlanOption]
  deriving Show
 instance Eq MediaType where
@@ -142,8 +142,3 @@ decodeMediaType mt =
  [PlanSettings | inOpts "settings"] ++
  [PlanBuffers | inOpts "buffers" ] ++
  [PlanWAL | inOpts "wal" ]
-
-getMediaType :: MediaType -> MediaType
-getMediaType mt = case mt of
- MTPlan mType _ _ -> mType
- other -> other

src/PostgREST/Plan.hs

@@ -59,7 +59,8 @@
  relIsToOne)
 import PostgREST.SchemaCache.Representations (DataRepresentation (..),
  RepresentationsMap)
-import PostgREST.SchemaCache.Routine (Routine (..),
+import PostgREST.SchemaCache.Routine (ResultAggregate (..),
+ Routine (..),
  RoutineMap,
  RoutineParam (..),
  funcReturnsCompositeAlias,
@@ -89,34 +90,36 @@
 data WrappedReadPlan = WrappedReadPlan {
  wrReadPlan :: ReadPlanTree
 , wrTxMode :: SQL.Mode
-, wrBinField :: Maybe FieldName
+, wrResAgg :: ResultAggregate
 }
 
 data MutateReadPlan = MutateReadPlan {
  mrReadPlan :: ReadPlanTree
 , mrMutatePlan :: MutatePlan
 , mrTxMode :: SQL.Mode
+, mrResAgg :: ResultAggregate
 }
 
 data CallReadPlan = CallReadPlan {
  crReadPlan :: ReadPlanTree
 , crCallPlan :: CallPlan
 , crTxMode :: SQL.Mode
 , crProc :: Routine
-, crBinField :: Maybe FieldName
+, crResAgg :: ResultAggregate
 }
 
 wrappedReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> Either Error WrappedReadPlan
 wrappedReadPlan identifier conf sCache apiRequest = do
  rPlan <- readPlan identifier conf sCache apiRequest
  binField <- mapLeft ApiRequestError $ binaryField conf (iAcceptMediaType apiRequest) Nothing rPlan
- return $ WrappedReadPlan rPlan SQL.Read binField
+ return $ WrappedReadPlan rPlan SQL.Read $ mediaToAggregate (iAcceptMediaType apiRequest) binField apiRequest
 
 mutateReadPlan :: Mutation -> ApiRequest -> QualifiedIdentifier -> AppConfig -> SchemaCache -> Either Error MutateReadPlan
 mutateReadPlan mutation apiRequest identifier conf sCache = do
  rPlan <- readPlan identifier conf sCache apiRequest
+ binField <- mapLeft ApiRequestError $ binaryField conf (iAcceptMediaType apiRequest) Nothing rPlan
  mPlan <- mutatePlan mutation identifier apiRequest sCache rPlan
- return $ MutateReadPlan rPlan mPlan SQL.Write
+ return $ MutateReadPlan rPlan mPlan SQL.Write $ mediaToAggregate (iAcceptMediaType apiRequest) binField apiRequest
 
 callReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> InvokeMethod -> Either Error CallReadPlan
 callReadPlan identifier conf sCache apiRequest invMethod = do
@@ -141,7 +144,7 @@
  (InvPost, Routine.Volatile) -> SQL.Write
  cPlan = callPlan proc apiRequest paramKeys args rPlan
  binField <- mapLeft ApiRequestError $ binaryField conf (iAcceptMediaType apiRequest) (Just proc) rPlan
- return $ CallReadPlan rPlan cPlan txMode proc binField
+ return $ CallReadPlan rPlan cPlan txMode proc $ mediaToAggregate (iAcceptMediaType apiRequest) binField apiRequest
  where
  Preferences{..} = iPreferences apiRequest
  qsParams' = QueryParams.qsParams (iQueryParams apiRequest)
@@ -835,3 +838,33 @@
  fstFieldName (Node ReadPlan{select=(CoercibleField{cfName="*", cfJsonPath=[]}, _, _):_} []) = Nothing
  fstFieldName (Node ReadPlan{select=[(CoercibleField{cfName=fld, cfJsonPath=[]}, _, _)]} []) = Just fld
  fstFieldName _ = Nothing
+
+
+mediaToAggregate :: MediaType -> Maybe FieldName -> ApiRequest -> ResultAggregate
+mediaToAggregate mt binField apiReq@ApiRequest{iAction=act, iPreferences=Preferences{preferRepresentation=rep}} =
+ if noAgg then NoAgg
+ else case mt of
+ MTApplicationJSON -> BuiltinAggJson
+ MTSingularJSON -> BuiltinAggSingleJson
+ MTGeoJSON -> BuiltinAggGeoJson
+ MTTextCSV -> BuiltinAggCsv
+ MTAny -> BuiltinAggJson
+ MTOpenAPI -> BuiltinAggJson
+ MTUrlEncoded -> NoAgg -- TODO: unreachable since a previous step (producedMediaTypes) whitelists the media types that can become aggregates.
+
+ -- binary types
+ MTTextPlain -> BuiltinAggBinary binField
+ MTTextXML -> BuiltinAggXml binField
+ MTOctetStream -> BuiltinAggBinary binField
+ MTOther _ -> BuiltinAggBinary binField
+
+ -- Doing `Accept: application/vnd.pgrst.plan; for="application/vnd.pgrst.plan"` doesn't make sense, so we just empty the body.
+ -- TODO: fail instead to be more strict
+ MTPlan (MTPlan{}) _ _ -> NoAgg
+ MTPlan media _ _ -> mediaToAggregate media binField apiReq
+ where
+ noAgg = case act of
+ ActionMutate _ -> rep == HeadersOnly || rep == None
+ ActionRead _isHead -> _isHead -- no need for an aggregate on HEAD https://github.com/PostgREST/postgrest/issues/2849
+ ActionInvoke invMethod -> invMethod == InvHead
+ _ -> False

src/PostgREST/Query.hs

@@ -65,7 +65,7 @@ import Protolude hiding (Handler)
 type DbHandler = ExceptT Error SQL.Transaction
 
 readQuery :: WrappedReadPlan -> AppConfig -> ApiRequest -> DbHandler ResultSet
-readQuery WrappedReadPlan{wrReadPlan, wrBinField} conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}, ..} = do
+readQuery WrappedReadPlan{wrReadPlan, wrResAgg} conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}, ..} = do
  let countQuery = QueryBuilder.readPlanToCountQuery wrReadPlan
  resultSet <-
  lift . SQL.statement mempty $
@@ -79,7 +79,7 @@ readQuery WrappedReadPlan{wrReadPlan, wrBinField} conf@AppConfig{..} apiReq@ApiR
  )
  (shouldCount preferCount)
  iAcceptMediaType
- wrBinField
+ wrResAgg
  configDbPreparedStatements
  failNotSingular iAcceptMediaType resultSet
  optionalRollback conf apiReq
@@ -150,7 +150,7 @@ deleteQuery mrPlan apiReq@ApiRequest{..} conf = do
  pure resultSet
 
 invokeQuery :: Routine -> CallReadPlan -> ApiRequest -> AppConfig -> PgVersion -> DbHandler ResultSet
-invokeQuery rout CallReadPlan{crReadPlan, crCallPlan, crBinField} apiReq@ApiRequest{iPreferences=Preferences{..}, ..} conf@AppConfig{..} pgVer = do
+invokeQuery rout CallReadPlan{crReadPlan, crCallPlan, crResAgg} apiReq@ApiRequest{iPreferences=Preferences{..}, ..} conf@AppConfig{..} pgVer = do
  resultSet <-
  lift . SQL.statement mempty $
  Statements.prepareCall
@@ -160,7 +160,7 @@ invokeQuery rout CallReadPlan{crReadPlan, crCallPlan, crBinField} apiReq@ApiRequ
  (QueryBuilder.readPlanToCountQuery crReadPlan)
  (shouldCount preferCount)
  iAcceptMediaType
- crBinField
+ crResAgg
  configDbPreparedStatements
 
  optionalRollback conf apiReq
@@ -185,7 +185,7 @@ openApiQuery sCache pgVer AppConfig{..} tSchema =
  pure Nothing
 
 writeQuery :: MutateReadPlan -> ApiRequest -> AppConfig -> DbHandler ResultSet
-writeQuery MutateReadPlan{mrReadPlan, mrMutatePlan} apiReq@ApiRequest{iPreferences=Preferences{..}} conf =
+writeQuery MutateReadPlan{mrReadPlan, mrMutatePlan, mrResAgg} apiReq@ApiRequest{iPreferences=Preferences{..}} conf =
  let
  (isInsert, pkCols) = case mrMutatePlan of {Insert{insPkCols} -> (True, insPkCols); _ -> (False, mempty);}
  in
@@ -195,6 +195,7 @@ writeQuery MutateReadPlan{mrReadPlan, mrMutatePlan} apiReq@ApiRequest{iPreferenc
  (QueryBuilder.mutatePlanToQuery mrMutatePlan)
  isInsert
  (iAcceptMediaType apiReq)
+ mrResAgg
  preferRepresentation
  pkCols
  (configDbPreparedStatements conf)

src/PostgREST/Query/SqlFragment.hs

@@ -7,12 +7,7 @@
 -}
 module PostgREST.Query.SqlFragment
  ( noLocationF
- , asBinaryF
- , asCsvF
- , asGeoJsonF
- , asJsonF
- , asJsonSingleF
- , asXmlF
+ , aggF
  , countF
  , fromQi
  , limitOffsetF
@@ -81,7 +76,8 @@
  rangeLimit, rangeOffset)
 import PostgREST.SchemaCache.Identifiers (FieldName,
  QualifiedIdentifier (..))
-import PostgREST.SchemaCache.Routine (Routine (..),
+import PostgREST.SchemaCache.Routine (ResultAggregate (..),
+ Routine (..),
  funcReturnsScalar,
  funcReturnsSetOfScalar,
  funcReturnsSingleComposite)
@@ -208,14 +204,18 @@
  Just r -> (funcReturnsSingleComposite r, funcReturnsScalar r, funcReturnsSetOfScalar r)
  Nothing -> (False, False, False)
 
-asXmlF :: FieldName -> SQL.Snippet
-asXmlF fieldName = "coalesce(xmlagg(_postgrest_t." <> pgFmtIdent fieldName <> "), '')"
+asXmlF :: Maybe FieldName -> SQL.Snippet
+asXmlF (Just fieldName) = "coalesce(xmlagg(_postgrest_t." <> pgFmtIdent fieldName <> "), '')"
+-- TODO unreachable because a previous step(binaryField) will validate that there's a field. This will be cleared once custom media types are implemented.
+asXmlF Nothing = "coalesce(xmlagg(_postgrest_t), '')"
 
 asGeoJsonF :: SQL.Snippet
 asGeoJsonF = "json_build_object('type', 'FeatureCollection', 'features', coalesce(json_agg(ST_AsGeoJSON(_postgrest_t)::json), '[]'))"
 
-asBinaryF :: FieldName -> SQL.Snippet
-asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
+asBinaryF :: Maybe FieldName -> SQL.Snippet
+asBinaryF (Just fieldName) = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
+-- TODO unreachable because a previous step(binaryField) will validate that there's a field. This will be cleared once custom media types are implemented.
+asBinaryF Nothing = "coalesce(string_agg(_postgrest_t, ''), '')"
 
 locationF :: [Text] -> SQL.Snippet
 locationF pKeys = [qc|(
@@ -491,3 +491,13 @@
  gucJsonVal = LBS.toStrict . JSON.encode . HM.fromList . arrayByteStringToText
  arrayByteStringToText :: [(ByteString, ByteString)] -> [(Text,Text)]
  arrayByteStringToText keyVal = (T.decodeUtf8 *** T.decodeUtf8) <$> keyVal
+
+aggF :: Maybe Routine -> ResultAggregate -> SQL.Snippet
+aggF rout = \case
+ BuiltinAggJson -> asJsonF rout
+ BuiltinAggSingleJson -> asJsonSingleF rout
+ BuiltinAggGeoJson -> asGeoJsonF
+ BuiltinAggCsv -> asCsvF
+ BuiltinAggXml bField -> asXmlF bField
+ BuiltinAggBinary bField -> asBinaryF bField
+ NoAgg -> "''::text"

src/PostgREST/Query/Statements.hs

@@ -23,15 +23,13 @@ import qualified Hasql.DynamicStatements.Statement as SQL
 import qualified Hasql.Statement as SQL
 
 import Control.Lens ((^?))
-import Data.Maybe (fromJust)
 
 import PostgREST.ApiRequest.Preferences
-import PostgREST.MediaType (MTPlanFormat (..),
- MediaType (..),
- getMediaType)
+import PostgREST.MediaType (MTPlanFormat (..),
+ MediaType (..))
 import PostgREST.Query.SqlFragment
-import PostgREST.SchemaCache.Identifiers (FieldName)
-import PostgREST.SchemaCache.Routine (Routine)
+import PostgREST.SchemaCache.Routine (ResultAggregate (..),
+   Routine)
 
 import Protolude
 
@@ -55,9 +53,9 @@ data ResultSet
  | RSPlan BS.ByteString -- ^ the plan of the query
 
 
-prepareWrite :: SQL.Snippet -> SQL.Snippet -> Bool -> MediaType ->
+prepareWrite :: SQL.Snippet -> SQL.Snippet -> Bool -> MediaType -> ResultAggregate ->
  PreferRepresentation -> [Text] -> Bool -> SQL.Statement () ResultSet
-prepareWrite selectQuery mutateQuery isInsert mt rep pKeys =
+prepareWrite selectQuery mutateQuery isInsert mt rAgg rep pKeys =
  SQL.dynamicallyParameterized (mtSnippet mt snippet) decodeIt
  where
  snippet =
@@ -66,7 +64,7 @@ prepareWrite selectQuery mutateQuery isInsert mt rep pKeys =
  "'' AS total_result_set, " <>
  "pg_catalog.count(_postgrest_t) AS page_total, " <>
  locF <> " AS header, " <>
- bodyF <> " AS body, " <>
+ aggF Nothing rAgg <> " AS body, " <>
  responseHeadersF <> " AS response_headers, " <>
  responseStatusF <> " AS response_status " <>
  "FROM (" <> selectF <> ") _postgrest_t"
@@ -80,25 +78,18 @@ prepareWrite selectQuery mutateQuery isInsert mt rep pKeys =
  "END"
  else noLocationF
 
- bodyF
- | rep /= Full = "''"
- | getMediaType mt == MTTextCSV = asCsvF
- | getMediaType mt == MTGeoJSON = asGeoJsonF
- | getMediaType mt == MTSingularJSON = asJsonSingleF Nothing
- | otherwise = asJsonF Nothing
-
  selectF
  -- prevent using any of the column names in ?select= when no response is returned from the CTE
- | rep /= Full = "SELECT * FROM " <> sourceCTE
- | otherwise = selectQuery
+ | rAgg == NoAgg = "SELECT * FROM " <> sourceCTE
+ | otherwise  = selectQuery
 
  decodeIt :: HD.Result ResultSet
  decodeIt = case mt of
  MTPlan{} -> planRow
  _ -> 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 =
+prepareRead :: SQL.Snippet -> SQL.Snippet -> Bool -> MediaType -> ResultAggregate -> Bool -> SQL.Statement () ResultSet
+prepareRead selectQuery countQuery countTotal mt rAgg =
  SQL.dynamicallyParameterized (mtSnippet mt snippet) decodeIt
  where
  snippet =
@@ -107,30 +98,22 @@ prepareRead selectQuery countQuery countTotal mt binaryField =
  "SELECT " <>
  countResultF <> " AS total_result_set, " <>
  "pg_catalog.count(_postgrest_t) AS page_total, " <>
- bodyF <> " AS body, " <>
+ aggF Nothing rAgg <> " AS body, " <>
  responseHeadersF <> " AS response_headers, " <>
  responseStatusF <> " AS response_status " <>
  "FROM ( SELECT * FROM " <> sourceCTE <> " ) _postgrest_t"
 
  (countCTEF, countResultF) = countF countQuery countTotal
 
- bodyF
- | getMediaType mt == MTTextCSV = asCsvF
- | getMediaType mt == MTSingularJSON = asJsonSingleF Nothing
- | getMediaType mt == MTGeoJSON = asGeoJsonF
- | isJust binaryField && getMediaType mt == MTTextXML = asXmlF $ fromJust binaryField
- | isJust binaryField = asBinaryF $ fromJust binaryField
- | otherwise = asJsonF Nothing
-
  decodeIt :: HD.Result ResultSet
  decodeIt = case mt of
  MTPlan{} -> planRow
  _ -> HD.singleRow $ standardRow True
 
 prepareCall :: Routine -> SQL.Snippet -> SQL.Snippet -> SQL.Snippet -> Bool ->
- MediaType -> Maybe FieldName -> Bool ->
+ MediaType -> ResultAggregate -> Bool ->
  SQL.Statement () ResultSet
-prepareCall rout callProcQuery selectQuery countQuery countTotal mt binaryField =
+prepareCall rout callProcQuery selectQuery countQuery countTotal mt rAgg =
  SQL.dynamicallyParameterized (mtSnippet mt snippet) decodeIt
  where
  snippet =
@@ -139,21 +122,13 @@ prepareCall rout callProcQuery selectQuery countQuery countTotal mt binaryField
  "SELECT " <>
  countResultF <> " AS total_result_set, " <>
  "pg_catalog.count(_postgrest_t) AS page_total, " <>
- bodyF <> " AS body, " <>
+ aggF (Just rout) rAgg <> " AS body, " <>
  responseHeadersF <> " AS response_headers, " <>
  responseStatusF <> " AS response_status " <>
  "FROM (" <> selectQuery <> ") _postgrest_t"
 
  (countCTEF, countResultF) = countF countQuery countTotal
 
- bodyF
- | getMediaType mt == MTSingularJSON = asJsonSingleF $ Just rout
- | getMediaType mt == MTTextCSV = asCsvF
- | getMediaType mt == MTGeoJSON = asGeoJsonF
- | isJust binaryField && getMediaType mt == MTTextXML = asXmlF $ fromJust binaryField
- | isJust binaryField = asBinaryF $ fromJust binaryField
- | otherwise = asJsonF $ Just rout
-
  decodeIt :: HD.Result ResultSet
  decodeIt = case mt of
  MTPlan{} -> planRow