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

pro/server/src/HasuraPro/App.hs

@@ -69,6 +69,7 @@ import qualified Hasura.GraphQL.Parser.Column              as Column
 import qualified Hasura.GraphQL.Transport.HTTP             as HGE
 import qualified Hasura.GraphQL.Transport.WebSocket.Server as HGE
 import qualified Hasura.Logging                            as L
+import qualified Hasura.RQL.IR.RemoteJoin                  as RJ
 import qualified Hasura.Metadata.Class                     as HGE
 import qualified Hasura.RQL.Types                          as HGE
 import qualified Hasura.Server.API.Query                   as HGE
@@ -149,7 +150,7 @@ extractTTL req =
     _ -> Nothing
 
 instance HGE.MonadExecuteQuery AppM where
-  cacheLookup query cacheKey@(HGE.QueryCacheKey req _user) = do
+  cacheLookup query queryPlan cacheKey@(HGE.QueryCacheKey req _user) = do
     connMay <- asks _acRedis
     projectId <- asks (_pcProjectId . _acProCreds)
     logger <- asks _acProLogger
@@ -160,7 +161,19 @@ instance HGE.MonadExecuteQuery AppM where
     policyConfig <- liftIO getPoliciesConfig
     let tenantCacheMaxTTL = _policyConfigCacheMaxTtl =<< policyConfig
         tenantCacheMaxSize  = _policyConfigCacheSizeLimit =<< policyConfig
-
+
+        -- We disallow caching for remote joins which involve forwarded
+        -- client headers. Otherwise, if the remote schema uses those for
+        -- authorization, we might leak client data across requests.
+        --
+        -- The use of any here is a shorthand for folding over multiple containers
+        -- to get to the RemoteSchemaInfo structures inside, but we don't need 
+        -- the full power of lens here.
+        hasRemoteJoinsForwardingHeaders = 
+          (any . any . any . any . any . any . any) 
+            (HGE.rsFwdClientHeaders . RJ._rjRemoteSchema)
+            queryPlan
+
         hasSessionVars :: [Context.QueryRootField (Column.UnpreparedValue 'HGE.Postgres)] -> Bool
         hasSessionVars = anyOf (traverse . EQ.traverseQueryRootField) \case
           Column.UVSession      -> True
@@ -176,8 +189,11 @@ instance HGE.MonadExecuteQuery AppM where
             HGE.throw400 HGE.NotSupported "This query depends on session variables and therefore cannot be cached"
           when (tenantCacheMaxTTL == Just 0 || tenantCacheMaxSize == Just 0) do
             HGE.throw400 HGE.NotSupported "Caching is not enabled"
-          when (ttlDirective > fromIntegral (fromMaybe defaultPolicyCacheMaxTTL tenantCacheMaxTTL)) do
-            HGE.throw400 HGE.NotSupported "The maximum allowed TTL is 300 seconds"
+          let maxTTL = fromMaybe defaultPolicyCacheMaxTTL tenantCacheMaxTTL
+          when (ttlDirective > fromIntegral maxTTL) do
+            HGE.throw400 HGE.NotSupported . fromString $ "The maximum allowed TTL is " <> show @Int maxTTL <> " seconds"
+          when hasRemoteJoinsForwardingHeaders do
+            HGE.throw400 HGE.NotSupported "Remote joins which forward client headers cannot currently be cached"
           -- The key we store in Redis is a combination of the project ID and
           -- the query hash.
           let key = mkRedisKey projectId cacheKey

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