Disallow caching for remote joins with forwarded headers (master) (#58)

GitOrigin-RevId: 76eb061534fd2a068965b8b22517a0729d9e3020

server/src-lib/Hasura/App.hs

@@ -648,7 +648,7 @@ instance HttpLog PGMetadataStorageApp where
       mkHttpAccessLogContext userInfoM reqId waiReq compressedResponse qTime cType headers
 
 instance MonadExecuteQuery PGMetadataStorageApp where
-  cacheLookup _ _ = pure ([], Nothing)
+  cacheLookup _ _ _ = pure ([], Nothing)
   cacheStore  _ _ = pure ()
 
 instance UserAuthentication (Tracing.TraceT PGMetadataStorageApp) where

server/src-lib/Hasura/GraphQL/Execute/Prepare.hs

@@ -59,6 +59,7 @@ data ExecutionStep db
   -- ^ A query to execute against a remote schema
   | ExecStepRaw J.Value
   -- ^ Output a plain JSON object
+  deriving (Functor, Foldable, Traversable)
 
 data PlanningSt
   = PlanningSt

server/src-lib/Hasura/GraphQL/Transport/HTTP.hs

@@ -21,6 +21,7 @@ import           Control.Monad.Morph                    (hoist)
 
 import           Hasura.EncJSON
 import           Hasura.GraphQL.Context
+import           Hasura.GraphQL.Execute.Prepare         (ExecutionPlan)
 import           Hasura.GraphQL.Logging                 (MonadQueryLog (..))
 import           Hasura.GraphQL.Parser.Column           (UnpreparedValue)
 import           Hasura.GraphQL.Transport.HTTP.Protocol
@@ -40,6 +41,7 @@ import qualified Data.Environment                       as Env
 import qualified Data.HashMap.Strict.InsOrd             as OMap
 import qualified Data.Text                              as T
 import qualified Database.PG.Query                      as Q
+import qualified Hasura.Backends.Postgres.Execute.RemoteJoin as RJ
 import qualified Hasura.GraphQL.Execute                 as E
 import qualified Hasura.GraphQL.Execute.Query           as EQ
 import qualified Hasura.Logging                         as L
@@ -67,6 +69,8 @@ class Monad m => MonadExecuteQuery m where
   cacheLookup
     :: [QueryRootField (UnpreparedValue 'Postgres)]
     -- ^ Used to check that the query is cacheable
+    -> ExecutionPlan (Maybe (Maybe (RJ.RemoteJoins 'Postgres)))
+    -- ^ Used to check if the elaborated query supports caching
     -> QueryCacheKey
     -- ^ Key that uniquely identifies the result of a query execution
     -> TraceT (ExceptT QErr m) (HTTP.ResponseHeaders, Maybe EncJSON)
@@ -93,15 +97,15 @@ class Monad m => MonadExecuteQuery m where
     -- ^ Always succeeds
 
 instance MonadExecuteQuery m => MonadExecuteQuery (ReaderT r m) where
-  cacheLookup a b = hoist (hoist lift) $ cacheLookup a b
+  cacheLookup a b c = hoist (hoist lift) $ cacheLookup a b c
   cacheStore  a b = hoist (hoist lift) $ cacheStore  a b
 
 instance MonadExecuteQuery m => MonadExecuteQuery (ExceptT r m) where
-  cacheLookup a b = hoist (hoist lift) $ cacheLookup a b
+  cacheLookup a b c = hoist (hoist lift) $ cacheLookup a b c
   cacheStore  a b = hoist (hoist lift) $ cacheStore  a b
 
 instance MonadExecuteQuery m => MonadExecuteQuery (TraceT m) where
-  cacheLookup a b = hoist (hoist lift) $ cacheLookup a b
+  cacheLookup a b c = hoist (hoist lift) $ cacheLookup a b c
   cacheStore  a b = hoist (hoist lift) $ cacheStore  a b
 
 data ResultsFragment = ResultsFragment
@@ -147,7 +151,8 @@ runGQ env logger reqId userInfo ipAddress reqHeaders queryType reqUnparsed = do
     (telemCacheHit,) <$> case execPlan of
       E.QueryExecutionPlan queryPlans asts -> trace "Query" $ do
         let cacheKey = QueryCacheKey reqParsed $ _uiRole userInfo
-        (responseHeaders, cachedValue) <- Tracing.interpTraceT (liftEitherM . runExceptT) $ cacheLookup asts cacheKey
+            redactedPlan = fmap (fmap (fmap EQ._psRemoteJoins . snd)) queryPlans
+        (responseHeaders, cachedValue) <- Tracing.interpTraceT (liftEitherM . runExceptT) $ cacheLookup asts redactedPlan cacheKey
         case cachedValue of
           Just cachedResponseData ->
             pure (Telem.Query, 0, Telem.Local, HttpResponse cachedResponseData responseHeaders)

server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs

@@ -367,9 +367,10 @@ onStart env serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
   case execPlan of
     E.QueryExecutionPlan queryPlan asts -> Tracing.trace "Query" $ do
       let cacheKey = QueryCacheKey reqParsed $ _uiRole userInfo
+          redactedPlan = fmap (fmap (fmap EQ._psRemoteJoins . snd)) queryPlan
       -- We ignore the response headers (containing TTL information) because
       -- WebSockets don't support them.
-      (_responseHeaders, cachedValue) <- Tracing.interpTraceT (withExceptT mempty) $ cacheLookup asts cacheKey
+      (_responseHeaders, cachedValue) <- Tracing.interpTraceT (withExceptT mempty) $ cacheLookup asts redactedPlan cacheKey
       case cachedValue of
         Just cachedResponseData -> do
           sendSuccResp cachedResponseData $ LQ.LiveQueryMetadata 0