From e332f038efb46f55d0f463d5ada2f6a812b6410d Mon Sep 17 00:00:00 2001
From: steve-chavez <stevechavezast@gmail.com>
Date: Sat, 8 Jul 2023 00:17:23 -0500
Subject: [PATCH] fix: HEAD unnecessarily executing aggregates

---
 CHANGELOG.md               |  1 +
 src/PostgREST/MediaType.hs |  6 ------
 src/PostgREST/Plan.hs      | 24 +++++++++++++++---------
 3 files changed, 16 insertions(+), 15 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 06e50c2add..5a241806c2 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -28,6 +28,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
 
diff --git a/src/PostgREST/MediaType.hs b/src/PostgREST/MediaType.hs
index d5288c693b..7ae4566462 100644
--- a/src/PostgREST/MediaType.hs
+++ b/src/PostgREST/MediaType.hs
@@ -7,7 +7,6 @@ module PostgREST.MediaType
   , toContentType
   , toMime
   , decodeMediaType
-  , getMediaType
   ) where
 
 import qualified Data.ByteString          as BS
@@ -143,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
diff --git a/src/PostgREST/Plan.hs b/src/PostgREST/Plan.hs
index 95fda7bca7..1bc05f7c59 100644
--- a/src/PostgREST/Plan.hs
+++ b/src/PostgREST/Plan.hs
@@ -112,14 +112,14 @@ wrappedReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest
 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 $ mediaToAggregate (iAcceptMediaType apiRequest) binField Nothing
+  return $ WrappedReadPlan rPlan SQL.Read $ mediaToAggregate (iAcceptMediaType apiRequest) binField apiRequest
 
 mutateReadPlan :: Mutation -> ApiRequest -> QualifiedIdentifier -> AppConfig -> SchemaCache -> Either Error MutateReadPlan
-mutateReadPlan  mutation apiRequest@ApiRequest{iPreferences=Preferences{preferRepresentation}} identifier conf sCache = do
+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 $ mediaToAggregate (iAcceptMediaType apiRequest) binField (Just preferRepresentation)
+  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
@@ -144,7 +144,7 @@ callReadPlan identifier conf sCache apiRequest invMethod = do
           (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 $ mediaToAggregate (iAcceptMediaType apiRequest) binField Nothing
+  return $ CallReadPlan rPlan cPlan txMode proc $ mediaToAggregate (iAcceptMediaType apiRequest) binField apiRequest
   where
     Preferences{..} = iPreferences apiRequest
     qsParams' = QueryParams.qsParams (iQueryParams apiRequest)
@@ -839,10 +839,10 @@ binaryField AppConfig{configRawMediaTypes} acceptMediaType proc rpTree
     fstFieldName (Node ReadPlan{select=[(CoercibleField{cfName=fld, cfJsonPath=[]}, _, _)]} [])  = Just fld
     fstFieldName _                                               = Nothing
 
-mediaToAggregate :: MediaType -> Maybe FieldName -> Maybe PreferRepresentation ->  ResultAggregate
-mediaToAggregate mt binField rep =
-  if rep == Just HeadersOnly || rep == Just None
-    then NoAgg
+
+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
@@ -861,4 +861,10 @@ mediaToAggregate mt binField rep =
     -- 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 rep
+    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