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

module Hasura.GraphQL.Schema.RemoteTest (spec) where

import           Hasura.Prelude

import qualified Data.Aeson                            as J
import qualified Data.ByteString.Lazy                  as LBS
import qualified Data.HashMap.Strict                   as M
import qualified Data.Text                             as T
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

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
import           Hasura.GraphQL.Parser.TestUtils
import           Hasura.GraphQL.RemoteServer           (identityCustomizer)
import           Hasura.GraphQL.Schema.Remote
import           Hasura.RQL.Types.RemoteSchema
import           Hasura.RQL.Types.SchemaCache
import           Hasura.Session


-- test tools

runError :: Monad m => ExceptT QErr m a -> m a
runError = runExceptT >=> (`onLeft` (error . T.unpack . qeError))


mkTestRemoteSchema :: Text -> RemoteSchemaIntrospection
mkTestRemoteSchema schema = RemoteSchemaIntrospection $ runIdentity $ runError $ do
  G.SchemaDocument types <- G.parseSchemaDocument schema `onLeft` throw500
  pure $ flip mapMaybe types \case
    G.TypeSystemDefinitionSchema _ -> Nothing
    G.TypeSystemDefinitionType td  -> Just $ case fmap toRemoteInputValue td of
      G.TypeDefinitionScalar      std -> G.TypeDefinitionScalar std
      G.TypeDefinitionObject      otd -> G.TypeDefinitionObject otd
      G.TypeDefinitionUnion       utd -> G.TypeDefinitionUnion  utd
      G.TypeDefinitionEnum        etd -> G.TypeDefinitionEnum   etd
      G.TypeDefinitionInputObject itd -> G.TypeDefinitionInputObject itd
      G.TypeDefinitionInterface   itd -> G.TypeDefinitionInterface $ G.InterfaceTypeDefinition
        { G._itdDescription      = G._itdDescription      itd
        , G._itdName             = G._itdName             itd
        , G._itdDirectives       = G._itdDirectives       itd
        , G._itdFieldsDefinition = G._itdFieldsDefinition itd
        , G._itdPossibleTypes    = []
        }
  where
    toRemoteInputValue ivd = RemoteSchemaInputValueDefinition
      { _rsitdDefinition     = ivd
      , _rsitdPresetArgument = choice $ G._ivdDirectives ivd <&> \dir -> do
          guard $ G._dName dir == $$(G.litName "preset")
          value <- M.lookup $$(G.litName "value") $ G._dArguments dir
          Just $ case value of
            G.VString "x-hasura-test" -> G.VVariable $
              SessionPresetVariable (mkSessionVariable "x-hasura-test") $$(G.litName "String") SessionArgumentPresetScalar
            _ -> absurd <$> value
      }

mkTestExecutableDocument :: Text -> ([G.VariableDefinition], G.SelectionSet G.NoFragments G.Name)
mkTestExecutableDocument t = runIdentity $ runError $ do
  G.ExecutableDocument execDoc <- G.parseExecutableDoc t `onLeft` throw500
  case execDoc of
    [G.ExecutableDefinitionOperation op] -> case op of
      G.OperationDefinitionUnTyped selSet -> ([],) <$> inlineSelectionSet [] selSet
      G.OperationDefinitionTyped   opDef  -> do
        unless (G._todType opDef == G.OperationTypeQuery) $
          throw500 "only queries for now"
        resSelSet <- inlineSelectionSet [] $ G._todSelectionSet opDef
        pure (G._todVariableDefinitions opDef, resSelSet)
    _ -> throw500 "must have only one query in the document"

mkTestVariableValues :: LBS.ByteString -> M.HashMap G.Name J.Value
mkTestVariableValues vars = runIdentity $ runError $ do
  value <- J.eitherDecode vars `onLeft` (throw500 . T.pack)
  case value of
    J.Object vs -> M.fromList <$> for (M.toList vs) \(name, val) -> do
      gname <- G.mkName name `onNothing` throw500 ("wrong Name: " <>> name)
      pure (gname, val)
    _           -> throw500 "variables must be an object"


buildQueryParsers
  :: RemoteSchemaIntrospection
  -> IO (P.FieldParser TestMonad (G.Field G.NoFragments RemoteSchemaVariable))
buildQueryParsers introspection = do
  let introResult = IntrospectionResult introspection $$(G.litName "Query") Nothing Nothing
  (query, _, _) <- runError
    $ runSchemaT
    $ buildRemoteParser introResult
    $ RemoteSchemaInfo (ValidatedRemoteSchemaDef N.nullURI [] False 60 Nothing) identityCustomizer
  pure $ head query <&> \(RemoteFieldG _ _ abstractField) ->
     case abstractField of
       RRFRealField f -> f
       RRFNamespaceField _ ->
         error "buildQueryParsers: unexpected RRFNamespaceField"
         -- Shouldn't happen if we're using identityCustomizer
         -- TODO: add some tests for remote schema customization


runQueryParser
  :: P.FieldParser TestMonad any
  -> ([G.VariableDefinition], G.SelectionSet G.NoFragments G.Name)
  -> M.HashMap G.Name J.Value
  -> any
runQueryParser parser (varDefs, selSet) vars = runIdentity . runError $ do
  (_, resolvedSelSet) <- resolveVariables varDefs vars [] selSet
  field <- case resolvedSelSet of
    [G.SelectionField f] -> pure f
    _                    -> error "expecting only one field in the query"
  runTest (P.fParser parser field) `onLeft` throw500

run
  :: Text           -- ^ schema
  -> Text           -- ^ query
  -> LBS.ByteString -- ^ variables
  -> IO (G.Field G.NoFragments RemoteSchemaVariable)
run schema query variables = do
  parser <- buildQueryParsers $ mkTestRemoteSchema schema
  pure $ runQueryParser
    parser
    (mkTestExecutableDocument query)
    (mkTestVariableValues variables)



-- actual test

spec :: Spec
spec = do
  testNoVarExpansionIfNoPreset
  testNoVarExpansionIfNoPresetUnlessTopLevelOptionalField
  testPartialVarExpansionIfPreset
  testVariableSubstitutionCollision

testNoVarExpansionIfNoPreset :: Spec
testNoVarExpansionIfNoPreset = it "variables aren't expanded if there's no preset" $ do
  field <- run
    -- schema
    [raw|
scalar Int

input A {
  b: B
}

input B {
  c: C
}

input C {
  i: Int
}

type Query {
  test(a: A!): Int
}
|]
    -- query
    [raw|
query($a: A!) {
  test(a: $a)
}
|]
    -- variables
    [raw|
{
  "a": {
    "b": {
      "c": {
        "i": 0
      }
    }
  }
}
|]
  let arg = head $ M.toList $ G._fArguments field
  arg `shouldBe`
    ( $$(G.litName "a")
    -- the parser did not create a new JSON variable, and forwarded the query variable unmodified
    , G.VVariable $ QueryVariable $ Variable
      (VIRequired $$(G.litName "a"))
      (G.TypeNamed (G.Nullability False) $$(G.litName "A"))
      (JSONValue $ J.Object $ M.fromList [("b", J.Object $ M.fromList [("c", J.Object $ M.fromList [("i", J.Number 0)])])])
    )

testNoVarExpansionIfNoPresetUnlessTopLevelOptionalField :: Spec
testNoVarExpansionIfNoPresetUnlessTopLevelOptionalField = it "unless fieldOptional peels the variable first" $ do
  field <- run
    -- schema
    [raw|
scalar Int

input A {
  b: B
}

input B {
  c: C
}

input C {
  i: Int
}

type Query {
  test(a: A): Int
}
|]
    -- query
    [raw|
query($a: A) {
  test(a: $a)
}
|]
    -- variables
    [raw|
{
  "a": {
    "b": {
      "c": {
        "i": 0
      }
    }
  }
}
|]
  let arg = head $ M.toList $ G._fArguments field
  arg `shouldBe`
    ( $$(G.litName "a")
    -- fieldOptional has peeled the variable; all we see is a JSON blob, and in doubt
    -- we repackage it as a newly minted JSON variable
    , G.VVariable $ RemoteJSONValue
      (G.TypeNamed (G.Nullability True) $$(G.litName "A"))
      (J.Object $ M.fromList [("b", J.Object $ M.fromList [("c", J.Object $ M.fromList [("i", J.Number 0)])])])
    )

testPartialVarExpansionIfPreset :: Spec
testPartialVarExpansionIfPreset = it "presets cause partial var expansion" $ do
  field <- run
    -- schema
    [raw|
scalar Int

input A {
  x: Int @preset(value: 0)
  b: B
}

input B {
  c: C
}

input C {
  i: Int
}

type Query {
  test(a: A!): Int
}
|]
    -- query
    [raw|
query($a: A!) {
  test(a: $a)
}
|]
    -- variables
    [raw|
{
  "a": {
    "b": {
      "c": {
        "i": 0
      }
    }
  }
}
|]
  let arg = head $ M.toList $ G._fArguments field
  arg `shouldBe`
    ( $$(G.litName "a")
    -- the preset has caused partial variable expansion, only up to where it's needed
    , G.VObject $ M.fromList
      [ ( $$(G.litName "x")
        , G.VInt 0
        )
      , ( $$(G.litName "b")
        , G.VVariable $ RemoteJSONValue
          (G.TypeNamed (G.Nullability True) $$(G.litName "B"))
          (J.Object $ M.fromList [("c", J.Object $ M.fromList [("i", J.Number 0)])])
        )
      ]
    )


-- | 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