server: Uses GraphQL type in remote variable cache key

https://github.com/hasura/graphql-engine-mono/pull/1801

GitOrigin-RevId: 98843e422b2431849b675acdb318ffae2f492f18

CHANGELOG.md

@@ -3,6 +3,7 @@
 ## Next release
 (Add entries below in the order of server, console, cli, docs, others)
 
+- server: prevent invalid collisions in remote variable cache key (close #7170)
 - server: preserve unchanged cron triggers in `replace_metadata` API
 - server: fix inherited roles bug where mutations were not accessible when inherited roles was enabled
 - server: reintroduce the unique name constraint in allowed lists

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveAnyClass #-}
+
 module Hasura.GraphQL.Execute.Remote
   ( buildExecStepRemote
   , collectVariablesFromSelectionSet
@@ -84,21 +86,38 @@ buildExecStepRemote remoteSchemaInfo resultCustomizer tp selSet =
       _grVariables = varValsM
   in ExecStepRemote remoteSchemaInfo resultCustomizer GH.GQLReq{_grOperationName = Nothing, ..}
 
+-- | Association between keys uniquely identifying some remote JSON variable and
+-- an 'Int' identifier that will be used to construct a valid variable name to
+-- be used in a GraphQL query.
+newtype RemoteJSONVariableMap =
+  RemoteJSONVariableMap (HashMap RemoteJSONVariableKey Int)
+  deriving newtype (Eq, Monoid, Semigroup)
 
--- | resolveRemoteVariable resolves a `RemoteSchemaVariable` into a GraphQL `Variable`. A
+-- | A unique identifier for some remote JSON variable whose name will need to
--- `RemoteSchemaVariable` can either be a query variable i.e. variable provided in the
+-- be substituted when constructing a GraphQL query.
--- query or it can be a `SessionPresetVariable` in which case we look up the value of the
--- session variable and coerce it into the appropriate type and then construct the GraphQL
--- `Variable`. *NOTE*: The session variable preset is a hard preset i.e. if the session
--- variable doesn't exist, an error will be thrown.
 --
--- The name of the GraphQL variable generated will be a GraphQL-ized (replacing '-' by
+-- For a detailed explanation of this behavior, see the following comment:
--- '_') version of the session variable, since session variables are not valid GraphQL
+-- https://github.com/hasura/graphql-engine/issues/7170#issuecomment-880838970
--- names.
+data RemoteJSONVariableKey = RemoteJSONVariableKey !G.GType !J.Value
+  deriving stock (Eq, Generic)
+  deriving anyclass (Hashable)
+
+-- | Resolves a `RemoteSchemaVariable` into a GraphQL `Variable`.
 --
--- Additionally, we need to handle partially traversed JSON values; likewise, we create a
+-- A `RemoteSchemaVariable` can either be a query variable (i.e. a variable
--- new variable out of thin air.
+-- provided in the query) or it can be a `SessionPresetVariable` (in which case
+-- we look up the value of the session variable and coerce it into the
+-- appropriate type and then construct the GraphQL 'Variable').
 --
+-- NOTE: The session variable preset is a hard preset (i.e. if the session
+-- variable doesn't exist, an error will be thrown).
+--
+-- The name of the GraphQL variable generated will be a GraphQL-ized version of
+-- the session variable (i.e. '-' will be replaced with '_'), since session
+-- variables are not valid GraphQL names.
+--
+-- Additionally, we need to handle partially traversed JSON values; likewise, we
+-- create a new variable out of thin air.
 --
 -- For example, considering the following schema for a role:
 --
@@ -125,8 +144,8 @@ buildExecStepRemote remoteSchemaInfo resultCustomizer tp selSet =
 --   { "foo": {"lastName": "Bar"} }
 --
 --
--- After resolving the session argument presets, the query that will be sent to the remote
+-- After resolving the session argument presets, the query that will be sent to
--- server will be:
+-- the remote server will be:
 --
 -- query ($x_hasura_user_id: Int!, $hasura_json_var_1: String!) {
 --   user (user_id: $x_hasura_user_id, user_name: {firstName: "Foo", lastName: $hasura_json_var_1}) {
@@ -139,7 +158,7 @@ resolveRemoteVariable
   :: (MonadError QErr m)
   => UserInfo
   -> RemoteSchemaVariable
-  -> StateT (HashMap J.Value Int) m Variable
+  -> StateT RemoteJSONVariableMap m Variable
 resolveRemoteVariable userInfo = \case
   SessionPresetVariable sessionVar typeName presetInfo -> do
     sessionVarVal <- onNothing (getSessionVariableValue sessionVar $ _uiSession userInfo)
@@ -184,24 +203,27 @@ resolveRemoteVariable userInfo = \case
     let variableGType = G.TypeNamed (G.Nullability False) typeName
     pure $ Variable (VIRequired varName) variableGType (GraphQLValue coercedValue)
   RemoteJSONValue gtype jsonValue -> do
-    cache <- get
+    let key = RemoteJSONVariableKey gtype jsonValue
-    index <- Map.lookup jsonValue cache `onNothing` do
+    varMap <- gets coerce
-      let i = Map.size cache + 1
+    index <- Map.lookup key varMap `onNothing` do
-      put $ Map.insert jsonValue i cache
+      let i = Map.size varMap + 1
+      put . coerce $ Map.insert key i varMap
       pure i
     let varName = G.unsafeMkName $ "hasura_json_var_" <> tshow index
     pure $ Variable (VIRequired varName) gtype $ JSONValue jsonValue
   QueryVariable variable -> pure variable
 
+-- | TODO: Documentation.
 resolveRemoteField
   :: (MonadError QErr m, Traversable f)
   => UserInfo
   -> RemoteFieldG f RemoteSchemaVariable
-  -> StateT (HashMap J.Value Int) m (RemoteFieldG f Variable)
+  -> StateT RemoteJSONVariableMap m (RemoteFieldG f Variable)
 resolveRemoteField userInfo = traverse (resolveRemoteVariable userInfo)
 
+-- | TODO: Documentation.
 runVariableCache
   :: Monad m
-  => StateT (HashMap J.Value Int) m a
+  => StateT RemoteJSONVariableMap m a
   -> m a
 runVariableCache = flip evalStateT mempty

server/src-lib/Hasura/RQL/Types/RemoteSchema.hs

@@ -300,9 +300,10 @@ data SessionArgumentPresetInfo
 instance Hashable SessionArgumentPresetInfo
 instance Cacheable SessionArgumentPresetInfo
 
--- | RemoteSchemaVariable is used to capture all the details required
+-- | Details required to resolve a "session variable preset" variable.
---   to resolve a session preset variable.
+--
---   See Note [Remote Schema Permissions Architecture]
+-- See Notes [Remote Schema Argument Presets] and [Remote Schema Permissions
+-- Architecture] for additional information.
 data RemoteSchemaVariable
   = SessionPresetVariable !SessionVariable !G.Name !SessionArgumentPresetInfo
   | QueryVariable !Variable
@@ -311,8 +312,9 @@ data RemoteSchemaVariable
 instance Hashable RemoteSchemaVariable
 instance Cacheable RemoteSchemaVariable
 
--- | This data type is an extension of the `G.InputValueDefinition`, it
+-- | Extends 'G.InputValueDefinition' with an optional preset argument.
---   may contain a preset with it.
+--
+-- See Note [Remote Schema Argument Presets] for additional information.
 data RemoteSchemaInputValueDefinition
   = RemoteSchemaInputValueDefinition
   { _rsitdDefinition     :: !G.InputValueDefinition

server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs

@@ -10,6 +10,7 @@ import qualified Language.GraphQL.Draft.Parser         as G
 import qualified Language.GraphQL.Draft.Syntax         as G
 import qualified Network.URI                           as N
 
+import           Control.Lens                          (Prism', _Right, prism', to, (^..))
 import           Data.Text.Extended
 import           Data.Text.RawString
 import           Test.Hspec
@@ -18,6 +19,7 @@ import qualified Hasura.GraphQL.Parser.Internal.Parser as P
 
 import           Hasura.Base.Error
 import           Hasura.GraphQL.Execute.Inline
+import           Hasura.GraphQL.Execute.Remote         (resolveRemoteVariable, runVariableCache)
 import           Hasura.GraphQL.Execute.Resolve
 import           Hasura.GraphQL.Parser.Monad
 import           Hasura.GraphQL.Parser.Schema
@@ -107,11 +109,11 @@ buildQueryParsers introspection = do
 
 
 runQueryParser
-  :: P.FieldParser TestMonad a
+  :: P.FieldParser TestMonad any
   -> ([G.VariableDefinition], G.SelectionSet G.NoFragments G.Name)
   -> M.HashMap G.Name J.Value
-  -> a
+  -> any
-runQueryParser parser (varDefs, selSet) vars = runIdentity $ runError $ do
+runQueryParser parser (varDefs, selSet) vars = runIdentity . runError $ do
   (_, resolvedSelSet) <- resolveVariables varDefs vars [] selSet
   field <- case resolvedSelSet of
     [G.SelectionField f] -> pure f
@@ -119,16 +121,17 @@ runQueryParser parser (varDefs, selSet) vars = runIdentity $ runError $ do
   runTest (P.fParser parser field) `onLeft` throw500
 
 run
-  :: Text           -- schema
+  :: Text           -- ^ schema
-  -> Text           -- query
+  -> Text           -- ^ query
-  -> LBS.ByteString -- variables
+  -> LBS.ByteString -- ^ variables
   -> IO (G.Field G.NoFragments RemoteSchemaVariable)
-run s q v = do
+run schema query variables = do
-  parser <- buildQueryParsers $ mkTestRemoteSchema s
+  parser <- buildQueryParsers $ mkTestRemoteSchema schema
   pure $ runQueryParser
     parser
-    (mkTestExecutableDocument q)
+    (mkTestExecutableDocument query)
-    (mkTestVariableValues v)
+    (mkTestVariableValues variables)
+
 
 
 -- actual test
@@ -138,6 +141,7 @@ spec = do
   testNoVarExpansionIfNoPreset
   testNoVarExpansionIfNoPresetUnlessTopLevelOptionalField
   testPartialVarExpansionIfPreset
+  testVariableSubstitutionCollision
 
 testNoVarExpansionIfNoPreset :: Spec
 testNoVarExpansionIfNoPreset = it "variables aren't expanded if there's no preset" $ do
@@ -298,3 +302,62 @@ query($a: A!) {
         )
       ]
     )
+
+
+-- | Regression test for https://github.com/hasura/graphql-engine/issues/7170
+testVariableSubstitutionCollision :: Spec
+testVariableSubstitutionCollision = it "ensures that remote variables are de-duplicated by type and value, not just by value" $ do
+  field <- run schema query variables
+  let
+    dummyUserInfo =
+      UserInfo
+        adminRoleName
+        (mempty @SessionVariables)
+        BOFADisallowed
+  eField <-
+    runExceptT
+    . runVariableCache
+    . traverse (resolveRemoteVariable dummyUserInfo)
+    $ field
+  let
+    variableNames =
+      eField ^.. _Right . to G._fArguments . traverse . _VVariable . to vInfo . to getName . to G.unName
+  variableNames `shouldBe` ["hasura_json_var_1", "hasura_json_var_2"]
+  where
+    -- A schema whose values are representable as collections of JSON values.
+    schema :: Text
+    schema = [raw|
+scalar Int
+scalar String
+
+type Query {
+  test(a: [Int], b: [String]): Int
+}
+|]
+    -- A query against values from 'schema' using JSON variable substitution.
+    query :: Text
+    query = [raw|
+query($a: [Int], $b: [String]) {
+  test(a: $a, b: $b)
+}
+|]
+    -- Two identical JSON variables to substitute; 'schema' and 'query' declare
+    -- that these variables should have different types despite both being
+    -- empty collections.
+    variables :: LBS.ByteString
+    variables = [raw|
+{
+  "a": [],
+  "b": []
+}
+|]
+
+-- | Convenience function to focus on a 'G.VVariable' when pulling test values
+-- out in 'testVariableSubstitutionCollision'.
+_VVariable :: Prism' (G.Value var) var
+_VVariable = prism' upcast downcast
+  where
+    upcast = G.VVariable
+    downcast = \case
+      G.VVariable var -> Just var
+      _               -> Nothing