-- | Implements /variable resolution/ for GraphQL queries, which annotates the
-- use site of each GraphQL variable with its value.
module Hasura.GraphQL.Execute.Resolve
  ( resolveVariables,
  )
where

import Data.HashMap.Strict.Extended qualified as HashMap
import Data.HashSet qualified as HS
import Data.List qualified as L
import Data.Text qualified as T
import Data.Text.Extended
import Hasura.Base.Error
import Hasura.GraphQL.Parser.Names
import Hasura.GraphQL.Parser.Variable
import Hasura.GraphQL.Transport.HTTP.Protocol qualified as GH
import Hasura.Prelude
import Language.GraphQL.Draft.Syntax qualified as G

resolveVariables ::
  forall m fragments.
  (MonadError QErr m, Traversable fragments) =>
  [G.VariableDefinition] ->
  GH.VariableValues ->
  [G.Directive G.Name] ->
  G.SelectionSet fragments G.Name ->
  m
    ( [G.Directive Variable],
      G.SelectionSet fragments Variable
    )
resolveVariables :: forall (m :: * -> *) (fragments :: * -> *).
(MonadError QErr m, Traversable fragments) =>
[VariableDefinition]
-> VariableValues
-> [Directive Name]
-> SelectionSet fragments Name
-> m ([Directive Variable], SelectionSet fragments Variable)
resolveVariables [VariableDefinition]
definitions VariableValues
jsonValues [Directive Name]
directives SelectionSet fragments Name
selSet = do
  HashMap Name (NonEmpty Variable)
variablesByName <- (Variable -> Name)
-> [Variable] -> HashMap Name (NonEmpty Variable)
forall k (t :: * -> *) v.
(Hashable k, Foldable t) =>
(v -> k) -> t v -> HashMap k (NonEmpty v)
HashMap.groupOnNE Variable -> Name
forall a. HasName a => a -> Name
getName ([Variable] -> HashMap Name (NonEmpty Variable))
-> m [Variable] -> m (HashMap Name (NonEmpty Variable))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VariableDefinition -> m Variable)
-> [VariableDefinition] -> m [Variable]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse VariableDefinition -> m Variable
buildVariable [VariableDefinition]
definitions
  HashMap Name Variable
uniqueVariables <- ((Name -> NonEmpty Variable -> m Variable)
 -> HashMap Name (NonEmpty Variable) -> m (HashMap Name Variable))
-> HashMap Name (NonEmpty Variable)
-> (Name -> NonEmpty Variable -> m Variable)
-> m (HashMap Name Variable)
forall a b c. (a -> b -> c) -> b -> a -> c
flip
    (Name -> NonEmpty Variable -> m Variable)
-> HashMap Name (NonEmpty Variable) -> m (HashMap Name Variable)
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HashMap.traverseWithKey
    HashMap Name (NonEmpty Variable)
variablesByName
    \Name
variableName NonEmpty Variable
variableDefinitions ->
      case NonEmpty Variable
variableDefinitions of
        Variable
a :| [] -> Variable -> m Variable
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Variable
a
        NonEmpty Variable
_ ->
          Code -> Text -> m Variable
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ParseFailed
            (Text -> m Variable) -> Text -> m Variable
forall a b. (a -> b) -> a -> b
$ Text
"multiple definitions for variable "
            Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
variableName
  (([Directive Variable]
directives', SelectionSet fragments Variable
selSet'), HashSet Name
usedVariables) <- (StateT
   (HashSet Name)
   m
   ([Directive Variable], SelectionSet fragments Variable)
 -> HashSet Name
 -> m (([Directive Variable], SelectionSet fragments Variable),
       HashSet Name))
-> HashSet Name
-> StateT
     (HashSet Name)
     m
     ([Directive Variable], SelectionSet fragments Variable)
-> m (([Directive Variable], SelectionSet fragments Variable),
      HashSet Name)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (HashSet Name)
  m
  ([Directive Variable], SelectionSet fragments Variable)
-> HashSet Name
-> m (([Directive Variable], SelectionSet fragments Variable),
      HashSet Name)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT HashSet Name
forall a. Monoid a => a
mempty (StateT
   (HashSet Name)
   m
   ([Directive Variable], SelectionSet fragments Variable)
 -> m (([Directive Variable], SelectionSet fragments Variable),
       HashSet Name))
-> StateT
     (HashSet Name)
     m
     ([Directive Variable], SelectionSet fragments Variable)
-> m (([Directive Variable], SelectionSet fragments Variable),
      HashSet Name)
forall a b. (a -> b) -> a -> b
$ do
    [Directive Variable]
d <- (Directive Name -> StateT (HashSet Name) m (Directive Variable))
-> [Directive Name] -> StateT (HashSet Name) m [Directive Variable]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Name -> StateT (HashSet Name) m Variable)
-> Directive Name -> StateT (HashSet Name) m (Directive Variable)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Directive a -> f (Directive b)
traverse (HashMap Name Variable -> Name -> StateT (HashSet Name) m Variable
resolveVariable HashMap Name Variable
uniqueVariables)) [Directive Name]
directives
    SelectionSet fragments Variable
s <- (Selection fragments Name
 -> StateT (HashSet Name) m (Selection fragments Variable))
-> SelectionSet fragments Name
-> StateT (HashSet Name) m (SelectionSet fragments Variable)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Name -> StateT (HashSet Name) m Variable)
-> Selection fragments Name
-> StateT (HashSet Name) m (Selection fragments Variable)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Selection fragments a -> f (Selection fragments b)
traverse (HashMap Name Variable -> Name -> StateT (HashSet Name) m Variable
resolveVariable HashMap Name Variable
uniqueVariables)) SelectionSet fragments Name
selSet
    ([Directive Variable], SelectionSet fragments Variable)
-> StateT
     (HashSet Name)
     m
     ([Directive Variable], SelectionSet fragments Variable)
forall a. a -> StateT (HashSet Name) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Directive Variable]
d, SelectionSet fragments Variable
s)
  let variablesByNameSet :: HashSet Name
variablesByNameSet = [Name] -> HashSet Name
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([Name] -> HashSet Name)
-> (HashMap Name (NonEmpty Variable) -> [Name])
-> HashMap Name (NonEmpty Variable)
-> HashSet Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Name (NonEmpty Variable) -> [Name]
forall k v. HashMap k v -> [k]
HashMap.keys (HashMap Name (NonEmpty Variable) -> HashSet Name)
-> HashMap Name (NonEmpty Variable) -> HashSet Name
forall a b. (a -> b) -> a -> b
$ HashMap Name (NonEmpty Variable)
variablesByName
      jsonVariableNames :: HashSet Name
jsonVariableNames = [Name] -> HashSet Name
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ VariableValues -> [Name]
forall k v. HashMap k v -> [k]
HashMap.keys VariableValues
jsonValues
      -- At the time of writing, this check is disabled using
      -- a local binding because, the master branch doesn't implement this
      -- check.
      -- TODO: Do this check using a feature flag
      isVariableValidationEnabled :: Bool
isVariableValidationEnabled = Bool
False

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isVariableValidationEnabled Bool -> Bool -> Bool
&& HashSet Name
usedVariables HashSet Name -> HashSet Name -> Bool
forall a. Eq a => a -> a -> Bool
/= HashSet Name
variablesByNameSet)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed
    (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"following variable(s) have been defined, but have not been used in the query - "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat
      ( Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
L.intersperse Text
", "
          ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Name -> Text) -> [Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Text
G.unName
          ([Name] -> [Text]) -> [Name] -> [Text]
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
HS.toList
          (HashSet Name -> [Name]) -> HashSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.difference HashSet Name
variablesByNameSet HashSet Name
usedVariables
      )

  -- There may be variables which have a default value and may not be
  -- included in the variables JSON Map. So, we should only see, if a
  -- variable is inlcuded in the JSON Map, then it must be used in the
  -- query
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.difference HashSet Name
jsonVariableNames HashSet Name
usedVariables HashSet Name -> HashSet Name -> Bool
forall a. Eq a => a -> a -> Bool
/= HashSet Name
forall a. HashSet a
HS.empty)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed
    (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"unexpected variables in variableValues: "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat
      ( Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
L.intersperse Text
", "
          ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Name -> Text) -> [Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Text
G.unName
          ([Name] -> [Text]) -> [Name] -> [Text]
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
HS.toList
          (HashSet Name -> [Name]) -> HashSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.difference HashSet Name
jsonVariableNames HashSet Name
usedVariables
      )

  ([Directive Variable], SelectionSet fragments Variable)
-> m ([Directive Variable], SelectionSet fragments Variable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Directive Variable]
directives', SelectionSet fragments Variable
selSet')
  where
    buildVariable :: G.VariableDefinition -> m Variable
    buildVariable :: VariableDefinition -> m Variable
buildVariable G.VariableDefinition {Name
_vdName :: Name
_vdName :: VariableDefinition -> Name
G._vdName, GType
_vdType :: GType
_vdType :: VariableDefinition -> GType
G._vdType, Maybe (Value Void)
_vdDefaultValue :: Maybe (Value Void)
_vdDefaultValue :: VariableDefinition -> Maybe (Value Void)
G._vdDefaultValue} = do
      let defaultValue :: Value Void
defaultValue = Value Void -> Maybe (Value Void) -> Value Void
forall a. a -> Maybe a -> a
fromMaybe Value Void
forall var. Value var
G.VNull Maybe (Value Void)
_vdDefaultValue
          isOptional :: Bool
isOptional = Maybe (Value Void) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Value Void)
_vdDefaultValue Bool -> Bool -> Bool
|| GType -> Bool
G.isNullable GType
_vdType
      Maybe (InputValue Void)
value <- case Name -> VariableValues -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
_vdName VariableValues
jsonValues of
        Just Value
jsonValue -> Maybe (InputValue Void) -> m (Maybe (InputValue Void))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (InputValue Void) -> m (Maybe (InputValue Void)))
-> Maybe (InputValue Void) -> m (Maybe (InputValue Void))
forall a b. (a -> b) -> a -> b
$ InputValue Void -> Maybe (InputValue Void)
forall a. a -> Maybe a
Just (InputValue Void -> Maybe (InputValue Void))
-> InputValue Void -> Maybe (InputValue Void)
forall a b. (a -> b) -> a -> b
$ Value -> InputValue Void
forall v. Value -> InputValue v
JSONValue Value
jsonValue
        Maybe Value
Nothing
          -- If the variable value was not provided, and the variable has no
          -- default value, then don't store a value for the variable.
          | Bool
isOptional -> Maybe (InputValue Void) -> m (Maybe (InputValue Void))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (InputValue Void) -> m (Maybe (InputValue Void)))
-> Maybe (InputValue Void) -> m (Maybe (InputValue Void))
forall a b. (a -> b) -> a -> b
$ Value Void -> InputValue Void
forall v. Value v -> InputValue v
GraphQLValue (Value Void -> InputValue Void)
-> (Value Void -> Value Void) -> Value Void -> InputValue Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Void -> Void) -> Value Void -> Value Void
forall a b. (a -> b) -> Value a -> Value b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Void -> Void
forall a. Void -> a
absurd (Value Void -> InputValue Void)
-> Maybe (Value Void) -> Maybe (InputValue Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Value Void)
_vdDefaultValue
          | Bool
otherwise ->
              Code -> Text -> m (Maybe (InputValue Void))
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed
                (Text -> m (Maybe (InputValue Void)))
-> Text -> m (Maybe (InputValue Void))
forall a b. (a -> b) -> a -> b
$ Text
"expecting a value for non-nullable variable: "
                Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
_vdName
      Variable -> m Variable
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Variable -> m Variable) -> Variable -> m Variable
forall a b. (a -> b) -> a -> b
$! Variable
          { vInfo :: VariableInfo
vInfo =
              if Bool
isOptional
                then Name -> Value Void -> VariableInfo
VIOptional Name
_vdName Value Void
defaultValue
                else Name -> VariableInfo
VIRequired Name
_vdName,
            vType :: GType
vType = GType
_vdType,
            vValue :: Maybe (InputValue Void)
vValue = Maybe (InputValue Void)
value
          }
    resolveVariable :: HashMap G.Name Variable -> G.Name -> StateT (HS.HashSet G.Name) m Variable
    resolveVariable :: HashMap Name Variable -> Name -> StateT (HashSet Name) m Variable
resolveVariable HashMap Name Variable
variables Name
name = case Name -> HashMap Name Variable -> Maybe Variable
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
name HashMap Name Variable
variables of
      Just Variable
variable -> (HashSet Name -> HashSet Name) -> StateT (HashSet Name) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert Name
name) StateT (HashSet Name) m ()
-> StateT (HashSet Name) m Variable
-> StateT (HashSet Name) m Variable
forall a b.
StateT (HashSet Name) m a
-> StateT (HashSet Name) m b -> StateT (HashSet Name) m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Variable -> StateT (HashSet Name) m Variable
forall a. a -> StateT (HashSet Name) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Variable
variable
      Maybe Variable
Nothing -> Code -> Text -> StateT (HashSet Name) m Variable
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed (Text -> StateT (HashSet Name) m Variable)
-> Text -> StateT (HashSet Name) m Variable
forall a b. (a -> b) -> a -> b
$ Text
"unbound variable " Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
name