-- | How to construct and execute a call to a remote schema for a remote join.
--
-- There are three steps required to do this:
--   1. construct the call: given the requested fields, the phantom fields, the
--      values extracted by the LHS, construct a GraphQL query
--   2. execute that GraphQL query over the network
--   3. build a index of the variables out of the response
--
-- This can be done as one function, but we also export the individual steps for
-- debugging / test purposes. We congregate all intermediary state in the opaque
-- 'RemoteSchemaCall' type.
module Hasura.GraphQL.Execute.RemoteJoin.RemoteSchema
  ( -- * Executing a remote join
    makeRemoteSchemaJoinCall,

    -- * Individual steps
    RemoteSchemaCall,
    buildRemoteSchemaCall,
    executeRemoteSchemaCall,
    buildJoinIndex,
  )
where

import Control.Lens (view, _2, _3)
import Data.Aeson qualified as J
import Data.Aeson.Ordered qualified as AO
import Data.ByteString.Lazy qualified as BL
import Data.HashMap.Strict.Extended qualified as HashMap
import Data.IntMap.Strict qualified as IntMap
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Data.Text.Extended (commaSeparated, toTxt, (<<>), (<>>))
import Data.Validation (Validation (..), toEither)
import Hasura.Base.Error
import Hasura.Base.ErrorMessage (fromErrorMessage)
import Hasura.GraphQL.Execute.Remote
  ( getVariableDefinitionAndValue,
    resolveRemoteVariable,
    runVariableCache,
  )
import Hasura.GraphQL.Execute.RemoteJoin.Types
import Hasura.GraphQL.Parser qualified as P
import Hasura.GraphQL.Transport.HTTP.Protocol (GQLReq (..), GQLReqOutgoing)
import Hasura.Prelude
import Hasura.RQL.IR.RemoteSchema (convertSelectionSet)
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.ResultCustomization
import Hasura.RemoteSchema.SchemaCache
import Hasura.Session
import Hasura.Tracing (MonadTrace)
import Hasura.Tracing qualified as Tracing
import Language.GraphQL.Draft.Syntax qualified as G

-------------------------------------------------------------------------------
-- Executing a remote join

-- | Construct and execute a call to a remote schema for a remote join.
makeRemoteSchemaJoinCall ::
  (MonadError QErr m, MonadTrace m, MonadIO m) =>
  -- | Function to send a request over the network.
  (GQLReqOutgoing -> m BL.ByteString) ->
  -- | User information.
  UserInfo ->
  -- | Information about that remote join.
  RemoteSchemaJoin ->
  -- | Name of the field from the join arguments.
  FieldName ->
  -- | Mapping from 'JoinArgumentId' to its corresponding 'JoinArgument'.
  IntMap.IntMap JoinArgument ->
  -- | The resulting join index (see 'buildJoinIndex') if any.
  m (Maybe (IntMap.IntMap AO.Value))
makeRemoteSchemaJoinCall :: forall (m :: * -> *).
(MonadError QErr m, MonadTrace m, MonadIO m) =>
(GQLReqOutgoing -> m ByteString)
-> UserInfo
-> RemoteSchemaJoin
-> FieldName
-> IntMap JoinArgument
-> m (Maybe (IntMap Value))
makeRemoteSchemaJoinCall GQLReqOutgoing -> m ByteString
networkFunction UserInfo
userInfo RemoteSchemaJoin
remoteSchemaJoin FieldName
jaFieldName IntMap JoinArgument
joinArguments = do
  Text -> m (Maybe (IntMap Value)) -> m (Maybe (IntMap Value))
forall (m :: * -> *) a.
(MonadIO m, MonadTrace m) =>
Text -> m a -> m a
Tracing.newSpan (Text
"Remote join to remote schema for field " Text -> FieldName -> Text
forall t. ToTxt t => Text -> t -> Text
<>> FieldName
jaFieldName) do
    -- step 1: construct the internal intermediary representation
    Maybe RemoteSchemaCall
maybeRemoteCall <-
      Text -> m (Maybe RemoteSchemaCall) -> m (Maybe RemoteSchemaCall)
forall (m :: * -> *) a.
(MonadIO m, MonadTrace m) =>
Text -> m a -> m a
Tracing.newSpan Text
"Resolve execution step for remote join field"
        (m (Maybe RemoteSchemaCall) -> m (Maybe RemoteSchemaCall))
-> m (Maybe RemoteSchemaCall) -> m (Maybe RemoteSchemaCall)
forall a b. (a -> b) -> a -> b
$ RemoteSchemaJoin
-> IntMap JoinArgument -> UserInfo -> m (Maybe RemoteSchemaCall)
forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaJoin
-> IntMap JoinArgument -> UserInfo -> m (Maybe RemoteSchemaCall)
buildRemoteSchemaCall RemoteSchemaJoin
remoteSchemaJoin IntMap JoinArgument
joinArguments UserInfo
userInfo
    -- if there actually is a remote call:
    Maybe RemoteSchemaCall
-> (RemoteSchemaCall -> m (IntMap Value))
-> m (Maybe (IntMap Value))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe RemoteSchemaCall
maybeRemoteCall \RemoteSchemaCall
remoteCall -> do
      -- step 2: execute it over the network
      Object
responseValue <- (GQLReqOutgoing -> m ByteString) -> RemoteSchemaCall -> m Object
forall (m :: * -> *).
MonadError QErr m =>
(GQLReqOutgoing -> m ByteString) -> RemoteSchemaCall -> m Object
executeRemoteSchemaCall GQLReqOutgoing -> m ByteString
networkFunction RemoteSchemaCall
remoteCall
      -- step 3: build the join index
      Text -> m (IntMap Value) -> m (IntMap Value)
forall (m :: * -> *) a.
(MonadIO m, MonadTrace m) =>
Text -> m a -> m a
Tracing.newSpan Text
"Build remote join index"
        (m (IntMap Value) -> m (IntMap Value))
-> m (IntMap Value) -> m (IntMap Value)
forall a b. (a -> b) -> a -> b
$ RemoteSchemaCall -> Object -> m (IntMap Value)
forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaCall -> Object -> m (IntMap Value)
buildJoinIndex RemoteSchemaCall
remoteCall Object
responseValue

-------------------------------------------------------------------------------
-- Internal representation

-- | Intermediate type containing all of the information required to perform
-- a remote schema call, constructed from the static join information.
data RemoteSchemaCall = RemoteSchemaCall
  { RemoteSchemaCall -> ResultCustomizer
rscCustomizer :: ResultCustomizer,
    RemoteSchemaCall -> GQLReqOutgoing
rscGQLRequest :: GQLReqOutgoing,
    RemoteSchemaCall -> IntMap ResponsePath
rscResponsePaths :: IntMap.IntMap ResponsePath
  }

-- | Used to extract the value from a remote schema response.
--
-- For example: if a remote relationship is defined to retrieve data from some
-- deeply nested field, this is the path towards that deeply nested field.
newtype ResponsePath = ResponsePath (NE.NonEmpty G.Name)
  deriving stock (ResponsePath -> ResponsePath -> Bool
(ResponsePath -> ResponsePath -> Bool)
-> (ResponsePath -> ResponsePath -> Bool) -> Eq ResponsePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponsePath -> ResponsePath -> Bool
== :: ResponsePath -> ResponsePath -> Bool
$c/= :: ResponsePath -> ResponsePath -> Bool
/= :: ResponsePath -> ResponsePath -> Bool
Eq, Int -> ResponsePath -> ShowS
[ResponsePath] -> ShowS
ResponsePath -> String
(Int -> ResponsePath -> ShowS)
-> (ResponsePath -> String)
-> ([ResponsePath] -> ShowS)
-> Show ResponsePath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponsePath -> ShowS
showsPrec :: Int -> ResponsePath -> ShowS
$cshow :: ResponsePath -> String
show :: ResponsePath -> String
$cshowList :: [ResponsePath] -> ShowS
showList :: [ResponsePath] -> ShowS
Show)

-------------------------------------------------------------------------------
-- Step 1: building the remote call

-- | Constructs a 'RemoteSchemaCall' from some static information, such as the
-- definition of the join, and dynamic information such as the user's
-- information and the map of join arguments.
buildRemoteSchemaCall ::
  (MonadError QErr m) =>
  RemoteSchemaJoin ->
  IntMap.IntMap JoinArgument ->
  UserInfo ->
  m (Maybe RemoteSchemaCall)
buildRemoteSchemaCall :: forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaJoin
-> IntMap JoinArgument -> UserInfo -> m (Maybe RemoteSchemaCall)
buildRemoteSchemaCall RemoteSchemaJoin {NonEmpty FieldCall
HashMap Name (InputValue RemoteSchemaVariable)
HashMap FieldName JoinColumnAlias
ResultCustomizer
RemoteSchemaInfo
SelectionSet Void RemoteSchemaVariable
_rsjArgs :: HashMap Name (InputValue RemoteSchemaVariable)
_rsjResultCustomizer :: ResultCustomizer
_rsjSelSet :: SelectionSet Void RemoteSchemaVariable
_rsjJoinColumnAliases :: HashMap FieldName JoinColumnAlias
_rsjFieldCall :: NonEmpty FieldCall
_rsjRemoteSchema :: RemoteSchemaInfo
_rsjArgs :: RemoteSchemaJoin -> HashMap Name (InputValue RemoteSchemaVariable)
_rsjResultCustomizer :: RemoteSchemaJoin -> ResultCustomizer
_rsjSelSet :: RemoteSchemaJoin -> SelectionSet Void RemoteSchemaVariable
_rsjJoinColumnAliases :: RemoteSchemaJoin -> HashMap FieldName JoinColumnAlias
_rsjFieldCall :: RemoteSchemaJoin -> NonEmpty FieldCall
_rsjRemoteSchema :: RemoteSchemaJoin -> RemoteSchemaInfo
..} IntMap JoinArgument
arguments UserInfo
userInfo = do
  -- for each join argument, we generate a unique field, with the alias
  -- "f" <> argumentId
  IntMap
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
fields <- ((Int
  -> JoinArgument
  -> m (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
        ResultCustomizer))
 -> IntMap JoinArgument
 -> m (IntMap
         (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
          ResultCustomizer)))
-> IntMap JoinArgument
-> (Int
    -> JoinArgument
    -> m (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
          ResultCustomizer))
-> m (IntMap
        (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
         ResultCustomizer))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int
 -> JoinArgument
 -> m (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
       ResultCustomizer))
-> IntMap JoinArgument
-> m (IntMap
        (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
         ResultCustomizer))
forall (t :: * -> *) a b.
Applicative t =>
(Int -> a -> t b) -> IntMap a -> t (IntMap b)
IntMap.traverseWithKey IntMap JoinArgument
arguments ((Int
  -> JoinArgument
  -> m (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
        ResultCustomizer))
 -> m (IntMap
         (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
          ResultCustomizer)))
-> (Int
    -> JoinArgument
    -> m (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
          ResultCustomizer))
-> m (IntMap
        (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
         ResultCustomizer))
forall a b. (a -> b) -> a -> b
$ \Int
argumentId (JoinArgument HashMap FieldName Value
argument) -> do
    HashMap Name (Value Void)
graphqlArgs <- ([(Name, Value Void)] -> HashMap Name (Value Void))
-> m [(Name, Value Void)] -> m (HashMap Name (Value Void))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Name, Value Void)] -> HashMap Name (Value Void)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
      (m [(Name, Value Void)] -> m (HashMap Name (Value Void)))
-> m [(Name, Value Void)] -> m (HashMap Name (Value Void))
forall a b. (a -> b) -> a -> b
$ [(FieldName, Value)]
-> ((FieldName, Value) -> m (Name, Value Void))
-> m [(Name, Value Void)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (HashMap FieldName Value -> [(FieldName, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap FieldName Value
argument) \(FieldName Text
columnName, Value
value) -> do
        Name
graphQLName <- Text -> m Name
forall (m :: * -> *). MonadError QErr m => Text -> m Name
parseGraphQLName Text
columnName
        Value Void
graphQLValue <- Value -> m (Value Void)
forall (n :: * -> *). MonadError QErr n => Value -> n (Value Void)
ordJSONValueToGValue Value
value
        (Name, Value Void) -> m (Name, Value Void)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
graphQLName, Value Void
graphQLValue)
    -- Creating the alias should never fail.
    let aliasText :: Text
aliasText = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"f" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
argumentId
    Name
alias <-
      Text -> Maybe Name
G.mkName Text
aliasText
        Maybe Name -> m Name -> m Name
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` Text -> m Name
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 (Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aliasText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is not a valid GraphQL name!")
    let responsePath :: NonEmpty Name
responsePath = Name
alias Name -> [Name] -> NonEmpty Name
forall a. a -> [a] -> NonEmpty a
NE.:| (FieldCall -> Name) -> [FieldCall] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldCall -> Name
fcName (NonEmpty FieldCall -> [FieldCall]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty FieldCall
_rsjFieldCall)
        rootField :: Name
rootField = FieldCall -> Name
fcName (FieldCall -> Name) -> FieldCall -> Name
forall a b. (a -> b) -> a -> b
$ NonEmpty FieldCall -> FieldCall
forall a. NonEmpty a -> a
NE.head NonEmpty FieldCall
_rsjFieldCall
        resultCustomizer :: ResultCustomizer
resultCustomizer = AliasMapping -> ResultCustomizer -> ResultCustomizer
applyAliasMapping (Name -> Name -> AliasMapping
singletonAliasMapping Name
rootField Name
alias) ResultCustomizer
_rsjResultCustomizer
    Field NoFragments RemoteSchemaVariable
gqlField <- HashMap Name (InputValue RemoteSchemaVariable)
-> HashMap Name (Value Void)
-> SelectionSet NoFragments RemoteSchemaVariable
-> Name
-> NonEmpty FieldCall
-> m (Field NoFragments RemoteSchemaVariable)
forall (m :: * -> *).
MonadError QErr m =>
HashMap Name (InputValue RemoteSchemaVariable)
-> HashMap Name (Value Void)
-> SelectionSet NoFragments RemoteSchemaVariable
-> Name
-> NonEmpty FieldCall
-> m (Field NoFragments RemoteSchemaVariable)
fieldCallsToField HashMap Name (InputValue RemoteSchemaVariable)
_rsjArgs HashMap Name (Value Void)
graphqlArgs (SelectionSet Void RemoteSchemaVariable
-> SelectionSet NoFragments RemoteSchemaVariable
forall var.
Eq var =>
SelectionSet Void var -> SelectionSet NoFragments var
convertSelectionSet SelectionSet Void RemoteSchemaVariable
_rsjSelSet) Name
alias NonEmpty FieldCall
_rsjFieldCall
    (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
 ResultCustomizer)
-> m (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
      ResultCustomizer)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field NoFragments RemoteSchemaVariable
gqlField, NonEmpty Name
responsePath, ResultCustomizer
resultCustomizer)

  -- this constructs the actual GraphQL Request that can be sent to the remote
  Maybe
  (NonEmpty
     (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
      ResultCustomizer))
-> (NonEmpty
      (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
       ResultCustomizer)
    -> m RemoteSchemaCall)
-> m (Maybe RemoteSchemaCall)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([(Field NoFragments RemoteSchemaVariable, NonEmpty Name,
  ResultCustomizer)]
-> Maybe
     (NonEmpty
        (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
         ResultCustomizer))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([(Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)]
 -> Maybe
      (NonEmpty
         (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
          ResultCustomizer)))
-> [(Field NoFragments RemoteSchemaVariable, NonEmpty Name,
     ResultCustomizer)]
-> Maybe
     (NonEmpty
        (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
         ResultCustomizer))
forall a b. (a -> b) -> a -> b
$ IntMap
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
-> [(Field NoFragments RemoteSchemaVariable, NonEmpty Name,
     ResultCustomizer)]
forall a. IntMap a -> [a]
IntMap.elems IntMap
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
fields) ((NonEmpty
    (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
     ResultCustomizer)
  -> m RemoteSchemaCall)
 -> m (Maybe RemoteSchemaCall))
-> (NonEmpty
      (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
       ResultCustomizer)
    -> m RemoteSchemaCall)
-> m (Maybe RemoteSchemaCall)
forall a b. (a -> b) -> a -> b
$ \NonEmpty
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
neFields -> do
    GQLReqOutgoing
gqlRequest <-
      (NonEmpty (Field NoFragments Variable) -> GQLReqOutgoing)
-> m (NonEmpty (Field NoFragments Variable)) -> m GQLReqOutgoing
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Field NoFragments Variable) -> GQLReqOutgoing
fieldsToRequest
        (m (NonEmpty (Field NoFragments Variable)) -> m GQLReqOutgoing)
-> (((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
      ResultCustomizer)
     -> StateT RemoteJSONVariableMap m (Field NoFragments Variable))
    -> m (NonEmpty (Field NoFragments Variable)))
-> ((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
     ResultCustomizer)
    -> StateT RemoteJSONVariableMap m (Field NoFragments Variable))
-> m GQLReqOutgoing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT
  RemoteJSONVariableMap m (NonEmpty (Field NoFragments Variable))
-> m (NonEmpty (Field NoFragments Variable))
forall (m :: * -> *) a.
Monad m =>
StateT RemoteJSONVariableMap m a -> m a
runVariableCache
        (StateT
   RemoteJSONVariableMap m (NonEmpty (Field NoFragments Variable))
 -> m (NonEmpty (Field NoFragments Variable)))
-> (((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
      ResultCustomizer)
     -> StateT RemoteJSONVariableMap m (Field NoFragments Variable))
    -> StateT
         RemoteJSONVariableMap m (NonEmpty (Field NoFragments Variable)))
-> ((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
     ResultCustomizer)
    -> StateT RemoteJSONVariableMap m (Field NoFragments Variable))
-> m (NonEmpty (Field NoFragments Variable))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
-> ((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
     ResultCustomizer)
    -> StateT RemoteJSONVariableMap m (Field NoFragments Variable))
-> StateT
     RemoteJSONVariableMap m (NonEmpty (Field NoFragments Variable))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for NonEmpty
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
neFields
        (((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
  -> StateT RemoteJSONVariableMap m (Field NoFragments Variable))
 -> m GQLReqOutgoing)
-> ((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
     ResultCustomizer)
    -> StateT RemoteJSONVariableMap m (Field NoFragments Variable))
-> m GQLReqOutgoing
forall a b. (a -> b) -> a -> b
$ \(Field NoFragments RemoteSchemaVariable
field, NonEmpty Name
_, ResultCustomizer
_) -> (RemoteSchemaVariable -> StateT RemoteJSONVariableMap m Variable)
-> Field NoFragments RemoteSchemaVariable
-> StateT RemoteJSONVariableMap m (Field NoFragments 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) -> Field NoFragments a -> f (Field NoFragments b)
traverse (UserInfo
-> RemoteSchemaVariable -> StateT RemoteJSONVariableMap m Variable
forall (m :: * -> *).
MonadError QErr m =>
UserInfo
-> RemoteSchemaVariable -> StateT RemoteJSONVariableMap m Variable
resolveRemoteVariable UserInfo
userInfo) Field NoFragments RemoteSchemaVariable
field
    let customizer :: ResultCustomizer
customizer = ((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
  ResultCustomizer)
 -> ResultCustomizer)
-> IntMap
     (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
      ResultCustomizer)
-> ResultCustomizer
forall m a. Monoid m => (a -> m) -> IntMap a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Getting
  ResultCustomizer
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
  ResultCustomizer
-> (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
    ResultCustomizer)
-> ResultCustomizer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  ResultCustomizer
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
  ResultCustomizer
forall s t a b. Field3 s t a b => Lens s t a b
Lens
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
  ResultCustomizer
  ResultCustomizer
_3) IntMap
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
fields
        responsePath :: IntMap ResponsePath
responsePath = ((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
  ResultCustomizer)
 -> ResponsePath)
-> IntMap
     (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
      ResultCustomizer)
-> IntMap ResponsePath
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NonEmpty Name -> ResponsePath
ResponsePath (NonEmpty Name -> ResponsePath)
-> ((Field NoFragments RemoteSchemaVariable, NonEmpty Name,
     ResultCustomizer)
    -> NonEmpty Name)
-> (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
    ResultCustomizer)
-> ResponsePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (NonEmpty Name)
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
  (NonEmpty Name)
-> (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
    ResultCustomizer)
-> NonEmpty Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (NonEmpty Name)
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
  (NonEmpty Name)
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
  (NonEmpty Name)
  (NonEmpty Name)
_2) IntMap
  (Field NoFragments RemoteSchemaVariable, NonEmpty Name,
   ResultCustomizer)
fields
    RemoteSchemaCall -> m RemoteSchemaCall
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteSchemaCall -> m RemoteSchemaCall)
-> RemoteSchemaCall -> m RemoteSchemaCall
forall a b. (a -> b) -> a -> b
$ ResultCustomizer
-> GQLReqOutgoing -> IntMap ResponsePath -> RemoteSchemaCall
RemoteSchemaCall ResultCustomizer
customizer GQLReqOutgoing
gqlRequest IntMap ResponsePath
responsePath

-- | Fold nested 'FieldCall's into a bare 'Field', inserting the passed
-- selection set at the leaf of the tree we construct.
fieldCallsToField ::
  forall m.
  (MonadError QErr m) =>
  -- | user input arguments to the remote join field
  HashMap.HashMap G.Name (P.InputValue RemoteSchemaVariable) ->
  -- | Contains the values of the variables that have been defined in the remote join definition
  HashMap.HashMap G.Name (G.Value Void) ->
  -- | Inserted at leaf of nested FieldCalls
  G.SelectionSet G.NoFragments RemoteSchemaVariable ->
  -- | Top-level name to set for this Field
  G.Name ->
  NonEmpty FieldCall ->
  m (G.Field G.NoFragments RemoteSchemaVariable)
fieldCallsToField :: forall (m :: * -> *).
MonadError QErr m =>
HashMap Name (InputValue RemoteSchemaVariable)
-> HashMap Name (Value Void)
-> SelectionSet NoFragments RemoteSchemaVariable
-> Name
-> NonEmpty FieldCall
-> m (Field NoFragments RemoteSchemaVariable)
fieldCallsToField HashMap Name (InputValue RemoteSchemaVariable)
rrArguments HashMap Name (Value Void)
variables SelectionSet NoFragments RemoteSchemaVariable
finalSelSet Name
topAlias =
  (Field NoFragments RemoteSchemaVariable
 -> Field NoFragments RemoteSchemaVariable)
-> m (Field NoFragments RemoteSchemaVariable)
-> m (Field NoFragments RemoteSchemaVariable)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Field NoFragments RemoteSchemaVariable
f -> Field NoFragments RemoteSchemaVariable
f {_fAlias :: Maybe Name
G._fAlias = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
topAlias}) (m (Field NoFragments RemoteSchemaVariable)
 -> m (Field NoFragments RemoteSchemaVariable))
-> (NonEmpty FieldCall
    -> m (Field NoFragments RemoteSchemaVariable))
-> NonEmpty FieldCall
-> m (Field NoFragments RemoteSchemaVariable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty FieldCall -> m (Field NoFragments RemoteSchemaVariable)
nest
  where
    -- almost: `foldr nest finalSelSet`
    nest :: NonEmpty FieldCall -> m (G.Field G.NoFragments RemoteSchemaVariable)
    nest :: NonEmpty FieldCall -> m (Field NoFragments RemoteSchemaVariable)
nest ((FieldCall Name
name RemoteArguments
remoteArgs) :| [FieldCall]
rest) = do
      HashMap Name (Value RemoteSchemaVariable)
templatedArguments <- HashMap Name (Value Void)
-> HashMap Name (Value RemoteSchemaVariable)
convert (HashMap Name (Value Void)
 -> HashMap Name (Value RemoteSchemaVariable))
-> m (HashMap Name (Value Void))
-> m (HashMap Name (Value RemoteSchemaVariable))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Name (Value Void)
-> RemoteArguments -> m (HashMap Name (Value Void))
forall (m :: * -> *).
MonadError QErr m =>
HashMap Name (Value Void)
-> RemoteArguments -> m (HashMap Name (Value Void))
createArguments HashMap Name (Value Void)
variables RemoteArguments
remoteArgs
      HashMap Name (Value RemoteSchemaVariable)
graphQLarguments <- (InputValue RemoteSchemaVariable -> m (Value RemoteSchemaVariable))
-> HashMap Name (InputValue RemoteSchemaVariable)
-> m (HashMap Name (Value RemoteSchemaVariable))
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) -> HashMap Name a -> f (HashMap Name b)
traverse InputValue RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
peel HashMap Name (InputValue RemoteSchemaVariable)
rrArguments
      (HashMap Name (Value RemoteSchemaVariable)
args, SelectionSet NoFragments RemoteSchemaVariable
selSet) <- case [FieldCall] -> Maybe (NonEmpty FieldCall)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [FieldCall]
rest of
        Just NonEmpty FieldCall
f -> do
          Field NoFragments RemoteSchemaVariable
s <- NonEmpty FieldCall -> m (Field NoFragments RemoteSchemaVariable)
nest NonEmpty FieldCall
f
          (HashMap Name (Value RemoteSchemaVariable),
 SelectionSet NoFragments RemoteSchemaVariable)
-> m (HashMap Name (Value RemoteSchemaVariable),
      SelectionSet NoFragments RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Name (Value RemoteSchemaVariable)
templatedArguments, [Field NoFragments RemoteSchemaVariable
-> Selection NoFragments RemoteSchemaVariable
forall (frag :: * -> *) var. Field frag var -> Selection frag var
G.SelectionField Field NoFragments RemoteSchemaVariable
s])
        Maybe (NonEmpty FieldCall)
Nothing -> do
          HashMap Name (Value RemoteSchemaVariable)
arguments <-
            (Name
 -> Value RemoteSchemaVariable
 -> Value RemoteSchemaVariable
 -> m (Value RemoteSchemaVariable))
-> HashMap Name (Value RemoteSchemaVariable)
-> HashMap Name (Value RemoteSchemaVariable)
-> m (HashMap Name (Value RemoteSchemaVariable))
forall (m :: * -> *) k v.
(Monad m, Hashable k) =>
(k -> v -> v -> m v)
-> HashMap k v -> HashMap k v -> m (HashMap k v)
HashMap.unionWithM
              Name
-> Value RemoteSchemaVariable
-> Value RemoteSchemaVariable
-> m (Value RemoteSchemaVariable)
forall (m :: * -> *).
MonadError QErr m =>
Name
-> Value RemoteSchemaVariable
-> Value RemoteSchemaVariable
-> m (Value RemoteSchemaVariable)
combineValues
              HashMap Name (Value RemoteSchemaVariable)
graphQLarguments
              -- converting (G.Value Void) -> (G.Value Variable) to merge the
              -- 'rrArguments' with the 'variables'
              HashMap Name (Value RemoteSchemaVariable)
templatedArguments
          (HashMap Name (Value RemoteSchemaVariable),
 SelectionSet NoFragments RemoteSchemaVariable)
-> m (HashMap Name (Value RemoteSchemaVariable),
      SelectionSet NoFragments RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Name (Value RemoteSchemaVariable)
arguments, SelectionSet NoFragments RemoteSchemaVariable
finalSelSet)
      Field NoFragments RemoteSchemaVariable
-> m (Field NoFragments RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field NoFragments RemoteSchemaVariable
 -> m (Field NoFragments RemoteSchemaVariable))
-> Field NoFragments RemoteSchemaVariable
-> m (Field NoFragments RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ Maybe Name
-> Name
-> HashMap Name (Value RemoteSchemaVariable)
-> [Directive RemoteSchemaVariable]
-> SelectionSet NoFragments RemoteSchemaVariable
-> Field NoFragments RemoteSchemaVariable
forall (frag :: * -> *) var.
Maybe Name
-> Name
-> HashMap Name (Value var)
-> [Directive var]
-> SelectionSet frag var
-> Field frag var
G.Field Maybe Name
forall a. Maybe a
Nothing Name
name HashMap Name (Value RemoteSchemaVariable)
args [] SelectionSet NoFragments RemoteSchemaVariable
selSet

    convert :: HashMap.HashMap G.Name (G.Value Void) -> HashMap.HashMap G.Name (G.Value RemoteSchemaVariable)
    convert :: HashMap Name (Value Void)
-> HashMap Name (Value RemoteSchemaVariable)
convert = (Value Void -> Value RemoteSchemaVariable)
-> HashMap Name (Value Void)
-> HashMap Name (Value RemoteSchemaVariable)
forall a b. (a -> b) -> HashMap Name a -> HashMap Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value Void -> Value RemoteSchemaVariable
forall var. Value Void -> Value var
G.literal

    peel :: P.InputValue RemoteSchemaVariable -> m (G.Value RemoteSchemaVariable)
    peel :: InputValue RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
peel = \case
      P.GraphQLValue Value RemoteSchemaVariable
v -> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value RemoteSchemaVariable
v
      P.JSONValue Value
_ ->
        -- At this point, it is theoretically impossible that we have
        -- unpacked a variable into a JSONValue, as there's no "outer
        -- scope" at which this value could have been peeled.
        -- FIXME: check that this is correct!
        Text -> m (Value RemoteSchemaVariable)
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 Text
"internal error: encountered an already expanded variable when folding remote field arguments"

-- | Create an argument map using the inputs taken from the left hand side.
createArguments ::
  (MonadError QErr m) =>
  HashMap.HashMap G.Name (G.Value Void) ->
  RemoteArguments ->
  m (HashMap G.Name (G.Value Void))
createArguments :: forall (m :: * -> *).
MonadError QErr m =>
HashMap Name (Value Void)
-> RemoteArguments -> m (HashMap Name (Value Void))
createArguments HashMap Name (Value Void)
variables (RemoteArguments HashMap Name (Value Name)
arguments) =
  Validation [Text] (HashMap Name (Value Void))
-> Either [Text] (HashMap Name (Value Void))
forall e a. Validation e a -> Either e a
toEither ((Value Name -> Validation [Text] (Value Void))
-> HashMap Name (Value Name)
-> Validation [Text] (HashMap Name (Value Void))
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) -> HashMap Name a -> f (HashMap Name b)
traverse Value Name -> Validation [Text] (Value Void)
substituteVariables HashMap Name (Value Name)
arguments)
    Either [Text] (HashMap Name (Value Void))
-> ([Text] -> m (HashMap Name (Value Void)))
-> m (HashMap Name (Value Void))
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` (\[Text]
errors -> Code -> Text -> m (HashMap Name (Value Void))
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
Unexpected (Text -> m (HashMap Name (Value Void)))
-> Text -> m (HashMap Name (Value Void))
forall a b. (a -> b) -> a -> b
$ Text
"Found errors: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t (f :: * -> *). (ToTxt t, Foldable f) => f t -> Text
commaSeparated [Text]
errors)
  where
    substituteVariables :: Value Name -> Validation [Text] (Value Void)
substituteVariables = \case
      G.VVariable Name
variableName ->
        Name -> HashMap Name (Value Void) -> Maybe (Value Void)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
variableName HashMap Name (Value Void)
variables
          Maybe (Value Void)
-> Validation [Text] (Value Void) -> Validation [Text] (Value Void)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` [Text] -> Validation [Text] (Value Void)
forall err a. err -> Validation err a
Failure [Text
"Value for variable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
variableName Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" not provided"]
      G.VList [Value Name]
listValue ->
        ([Value Void] -> Value Void)
-> Validation [Text] [Value Void] -> Validation [Text] (Value Void)
forall a b. (a -> b) -> Validation [Text] a -> Validation [Text] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Value Void] -> Value Void
forall var. [Value var] -> Value var
G.VList ((Value Name -> Validation [Text] (Value Void))
-> [Value Name] -> Validation [Text] [Value Void]
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 Value Name -> Validation [Text] (Value Void)
substituteVariables [Value Name]
listValue)
      G.VObject HashMap Name (Value Name)
objectValue ->
        (HashMap Name (Value Void) -> Value Void)
-> Validation [Text] (HashMap Name (Value Void))
-> Validation [Text] (Value Void)
forall a b. (a -> b) -> Validation [Text] a -> Validation [Text] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HashMap Name (Value Void) -> Value Void
forall var. HashMap Name (Value var) -> Value var
G.VObject ((Value Name -> Validation [Text] (Value Void))
-> HashMap Name (Value Name)
-> Validation [Text] (HashMap Name (Value Void))
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) -> HashMap Name a -> f (HashMap Name b)
traverse Value Name -> Validation [Text] (Value Void)
substituteVariables HashMap Name (Value Name)
objectValue)
      G.VInt Integer
i -> Value Void -> Validation [Text] (Value Void)
forall a. a -> Validation [Text] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Void -> Validation [Text] (Value Void))
-> Value Void -> Validation [Text] (Value Void)
forall a b. (a -> b) -> a -> b
$ Integer -> Value Void
forall var. Integer -> Value var
G.VInt Integer
i
      G.VFloat Scientific
d -> Value Void -> Validation [Text] (Value Void)
forall a. a -> Validation [Text] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Void -> Validation [Text] (Value Void))
-> Value Void -> Validation [Text] (Value Void)
forall a b. (a -> b) -> a -> b
$ Scientific -> Value Void
forall var. Scientific -> Value var
G.VFloat Scientific
d
      G.VString Text
txt -> Value Void -> Validation [Text] (Value Void)
forall a. a -> Validation [Text] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Void -> Validation [Text] (Value Void))
-> Value Void -> Validation [Text] (Value Void)
forall a b. (a -> b) -> a -> b
$ Text -> Value Void
forall var. Text -> Value var
G.VString Text
txt
      G.VEnum EnumValue
e -> Value Void -> Validation [Text] (Value Void)
forall a. a -> Validation [Text] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Void -> Validation [Text] (Value Void))
-> Value Void -> Validation [Text] (Value Void)
forall a b. (a -> b) -> a -> b
$ EnumValue -> Value Void
forall var. EnumValue -> Value var
G.VEnum EnumValue
e
      G.VBoolean Bool
b -> Value Void -> Validation [Text] (Value Void)
forall a. a -> Validation [Text] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Void -> Validation [Text] (Value Void))
-> Value Void -> Validation [Text] (Value Void)
forall a b. (a -> b) -> a -> b
$ Bool -> Value Void
forall var. Bool -> Value var
G.VBoolean Bool
b
      Value Name
G.VNull -> Value Void -> Validation [Text] (Value Void)
forall a. a -> Validation [Text] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Void -> Validation [Text] (Value Void))
-> Value Void -> Validation [Text] (Value Void)
forall a b. (a -> b) -> a -> b
$ Value Void
forall var. Value var
G.VNull

-- | Combine two GraphQL values together.
--
-- This is used to combine different input arguments into one. This function can
-- only combine objects or lists pairwise, and fails if it has to combine any
-- other combination of values.
--
-- >>> combineValues (Object (fromList [("id", Number 1)]) (Object (fromList [("name", String "foo")])
-- Object (fromList [("id", Number 1), ("name", String "foo")])
combineValues ::
  (MonadError QErr m) =>
  G.Name ->
  G.Value RemoteSchemaVariable ->
  G.Value RemoteSchemaVariable ->
  m (G.Value RemoteSchemaVariable)
combineValues :: forall (m :: * -> *).
MonadError QErr m =>
Name
-> Value RemoteSchemaVariable
-> Value RemoteSchemaVariable
-> m (Value RemoteSchemaVariable)
combineValues Name
name Value RemoteSchemaVariable
v1 Value RemoteSchemaVariable
v2 = case (Value RemoteSchemaVariable
v1, Value RemoteSchemaVariable
v2) of
  (G.VObject HashMap Name (Value RemoteSchemaVariable)
l, G.VObject HashMap Name (Value RemoteSchemaVariable)
r) -> HashMap Name (Value RemoteSchemaVariable)
-> Value RemoteSchemaVariable
forall var. HashMap Name (Value var) -> Value var
G.VObject (HashMap Name (Value RemoteSchemaVariable)
 -> Value RemoteSchemaVariable)
-> m (HashMap Name (Value RemoteSchemaVariable))
-> m (Value RemoteSchemaVariable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
 -> Value RemoteSchemaVariable
 -> Value RemoteSchemaVariable
 -> m (Value RemoteSchemaVariable))
-> HashMap Name (Value RemoteSchemaVariable)
-> HashMap Name (Value RemoteSchemaVariable)
-> m (HashMap Name (Value RemoteSchemaVariable))
forall (m :: * -> *) k v.
(Monad m, Hashable k) =>
(k -> v -> v -> m v)
-> HashMap k v -> HashMap k v -> m (HashMap k v)
HashMap.unionWithM Name
-> Value RemoteSchemaVariable
-> Value RemoteSchemaVariable
-> m (Value RemoteSchemaVariable)
forall (m :: * -> *).
MonadError QErr m =>
Name
-> Value RemoteSchemaVariable
-> Value RemoteSchemaVariable
-> m (Value RemoteSchemaVariable)
combineValues HashMap Name (Value RemoteSchemaVariable)
l HashMap Name (Value RemoteSchemaVariable)
r
  (G.VList [Value RemoteSchemaVariable]
l, G.VList [Value RemoteSchemaVariable]
r) -> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable))
-> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ [Value RemoteSchemaVariable] -> Value RemoteSchemaVariable
forall var. [Value var] -> Value var
G.VList ([Value RemoteSchemaVariable] -> Value RemoteSchemaVariable)
-> [Value RemoteSchemaVariable] -> Value RemoteSchemaVariable
forall a b. (a -> b) -> a -> b
$ [Value RemoteSchemaVariable]
l [Value RemoteSchemaVariable]
-> [Value RemoteSchemaVariable] -> [Value RemoteSchemaVariable]
forall a. Semigroup a => a -> a -> a
<> [Value RemoteSchemaVariable]
r
  (Value RemoteSchemaVariable
l, Value RemoteSchemaVariable
r) ->
    Text -> m (Value RemoteSchemaVariable)
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500
      (Text -> m (Value RemoteSchemaVariable))
-> Text -> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ Text
"combineValues: cannot combine values ("
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value RemoteSchemaVariable -> Text
forall a. Show a => a -> Text
tshow Value RemoteSchemaVariable
l
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") and ("
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value RemoteSchemaVariable -> Text
forall a. Show a => a -> Text
tshow Value RemoteSchemaVariable
r
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") for field "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
name
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; lists can only be merged with lists, objects can only be merged with objects"

-- | Craft a GraphQL query document from the list of fields.
fieldsToRequest :: NonEmpty (G.Field G.NoFragments P.Variable) -> GQLReqOutgoing
fieldsToRequest :: NonEmpty (Field NoFragments Variable) -> GQLReqOutgoing
fieldsToRequest NonEmpty (Field NoFragments Variable)
gFields =
  GQLReq
    { _grOperationName :: Maybe OperationName
_grOperationName = Maybe OperationName
forall a. Maybe a
Nothing,
      _grVariables :: Maybe VariableValues
_grVariables =
        if HashMap VariableDefinition Value -> Bool
forall k v. HashMap k v -> Bool
HashMap.null HashMap VariableDefinition Value
variableInfos
          then Maybe VariableValues
forall a. Maybe a
Nothing
          else VariableValues -> Maybe VariableValues
forall a. a -> Maybe a
Just (VariableValues -> Maybe VariableValues)
-> VariableValues -> Maybe VariableValues
forall a b. (a -> b) -> a -> b
$ (VariableDefinition -> Name)
-> HashMap VariableDefinition Value -> VariableValues
forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
mapKeys VariableDefinition -> Name
G._vdName HashMap VariableDefinition Value
variableInfos,
      _grQuery :: TypedOperationDefinition NoFragments Name
_grQuery =
        G.TypedOperationDefinition
          { _todSelectionSet :: SelectionSet NoFragments Name
G._todSelectionSet =
              -- convert from Field Variable to Field Name
              NonEmpty (Selection NoFragments Name)
-> SelectionSet NoFragments Name
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (Selection NoFragments Name)
 -> SelectionSet NoFragments Name)
-> NonEmpty (Selection NoFragments Name)
-> SelectionSet NoFragments Name
forall a b. (a -> b) -> a -> b
$ Field NoFragments Name -> Selection NoFragments Name
forall (frag :: * -> *) var. Field frag var -> Selection frag var
G.SelectionField (Field NoFragments Name -> Selection NoFragments Name)
-> (Field NoFragments Variable -> Field NoFragments Name)
-> Field NoFragments Variable
-> Selection NoFragments Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Variable -> Name)
-> Field NoFragments Variable -> Field NoFragments Name
forall a b. (a -> b) -> Field NoFragments a -> Field NoFragments b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Variable -> Name
forall a. HasName a => a -> Name
P.getName (Field NoFragments Variable -> Selection NoFragments Name)
-> NonEmpty (Field NoFragments Variable)
-> NonEmpty (Selection NoFragments Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Field NoFragments Variable)
gFields,
            _todVariableDefinitions :: [VariableDefinition]
G._todVariableDefinitions = HashMap VariableDefinition Value -> [VariableDefinition]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap VariableDefinition Value
variableInfos,
            _todType :: OperationType
G._todType = OperationType
G.OperationTypeQuery,
            _todName :: Maybe Name
G._todName = Maybe Name
forall a. Maybe a
Nothing,
            _todDirectives :: [Directive Name]
G._todDirectives = []
          }
    }
  where
    variableInfos :: HashMap G.VariableDefinition J.Value
    variableInfos :: HashMap VariableDefinition Value
variableInfos = [(VariableDefinition, Value)] -> HashMap VariableDefinition Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(VariableDefinition, Value)] -> HashMap VariableDefinition Value)
-> [(VariableDefinition, Value)]
-> HashMap VariableDefinition Value
forall a b. (a -> b) -> a -> b
$ (Field NoFragments Variable -> [(VariableDefinition, Value)])
-> NonEmpty (Field NoFragments Variable)
-> [(VariableDefinition, Value)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Variable -> [(VariableDefinition, Value)])
-> Field NoFragments Variable -> [(VariableDefinition, Value)]
forall m a. Monoid m => (a -> m) -> Field NoFragments a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Variable -> [(VariableDefinition, Value)]
getVariableInfo) NonEmpty (Field NoFragments Variable)
gFields
    getVariableInfo :: P.Variable -> [(G.VariableDefinition, J.Value)]
    getVariableInfo :: Variable -> [(VariableDefinition, Value)]
getVariableInfo = (VariableDefinition, Value) -> [(VariableDefinition, Value)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VariableDefinition, Value) -> [(VariableDefinition, Value)])
-> (Variable -> (VariableDefinition, Value))
-> Variable
-> [(VariableDefinition, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Value) -> Value)
-> (VariableDefinition, (Name, Value))
-> (VariableDefinition, Value)
forall a b.
(a -> b) -> (VariableDefinition, a) -> (VariableDefinition, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, Value) -> Value
forall a b. (a, b) -> b
snd ((VariableDefinition, (Name, Value))
 -> (VariableDefinition, Value))
-> (Variable -> (VariableDefinition, (Name, Value)))
-> Variable
-> (VariableDefinition, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> (VariableDefinition, (Name, Value))
getVariableDefinitionAndValue

------------------------------------------------------------------------------
-- Step 2: sending the call over the network

-- | Sends the call over the network, and parse the resulting ByteString.
executeRemoteSchemaCall ::
  (MonadError QErr m) =>
  -- | Function to send a request over the network.
  (GQLReqOutgoing -> m BL.ByteString) ->
  -- | Information about that call.
  RemoteSchemaCall ->
  -- | Resulting JSON object
  m AO.Object
executeRemoteSchemaCall :: forall (m :: * -> *).
MonadError QErr m =>
(GQLReqOutgoing -> m ByteString) -> RemoteSchemaCall -> m Object
executeRemoteSchemaCall GQLReqOutgoing -> m ByteString
networkFunction (RemoteSchemaCall ResultCustomizer
customizer GQLReqOutgoing
request IntMap ResponsePath
_) = do
  ByteString
responseBody <- GQLReqOutgoing -> m ByteString
networkFunction GQLReqOutgoing
request
  Value
responseJSON <-
    ByteString -> Either String Value
AO.eitherDecode ByteString
responseBody
      Either String Value -> (String -> m Value) -> m Value
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` (\String
e -> Text -> m Value
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 (Text -> m Value) -> Text -> m Value
forall a b. (a -> b) -> a -> b
$ Text
"Remote server response is not valid JSON: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e)
  Object
responseObject <- Value -> Either Text Object
forall s. IsString s => Value -> Either s Object
AO.asObject Value
responseJSON Either Text Object -> (Text -> m Object) -> m Object
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` Text -> m Object
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500
  let errors :: Maybe Value
errors = Text -> Object -> Maybe Value
AO.lookup Text
"errors" Object
responseObject
  if
    | Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Value
errors Bool -> Bool -> Bool
|| Maybe Value
errors Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
AO.Null ->
        case Text -> Object -> Maybe Value
AO.lookup Text
"data" Object
responseObject of
          Maybe Value
Nothing -> Text -> m Object
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 Text
"\"data\" field not found in remote response"
          Just Value
v ->
            let v' :: Value
v' = ResultCustomizer -> Value -> Value
applyResultCustomizer ResultCustomizer
customizer Value
v
             in Value -> Either Text Object
forall s. IsString s => Value -> Either s Object
AO.asObject Value
v' Either Text Object -> (Text -> m Object) -> m Object
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` Text -> m Object
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500
    | Bool
otherwise ->
        QErr -> m Object
forall a. QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
          (Code -> Text -> QErr
err400 Code
Unexpected Text
"Errors from remote server")
            { qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
J.object [Key
"errors" Key -> Maybe Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= (Value -> Value
AO.fromOrdered (Value -> Value) -> Maybe Value -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
errors)]
            }

-------------------------------------------------------------------------------
-- Step 3: extracting the join index

-- | Construct a join index from the remote source's 'AO.Value' response.
--
-- This function extracts from the 'RemoteJoinCall' a mapping from
-- 'JoinArgumentId' to 'ResponsePath': from an integer that uniquely identifies
-- a join argument to the "path" at which we expect that value in the
-- response. With it, and with the actual reponse JSON value obtained from the
-- remote server, it constructs a corresponding mapping of, for each argument,
-- its extracted value.
--
-- If the response does not have value at any of the provided 'ResponsePath's,
-- throw a generic 'QErr'.
--
-- NOTE(jkachmar): If we switch to an 'Applicative' validator, we can collect
-- more than one missing 'ResponsePath's (rather than short-circuiting on the
-- first missing value).
buildJoinIndex ::
  forall m.
  (MonadError QErr m) =>
  RemoteSchemaCall ->
  AO.Object ->
  m (IntMap.IntMap AO.Value)
buildJoinIndex :: forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaCall -> Object -> m (IntMap Value)
buildJoinIndex RemoteSchemaCall {IntMap ResponsePath
ResultCustomizer
GQLReqOutgoing
rscCustomizer :: RemoteSchemaCall -> ResultCustomizer
rscGQLRequest :: RemoteSchemaCall -> GQLReqOutgoing
rscResponsePaths :: RemoteSchemaCall -> IntMap ResponsePath
rscCustomizer :: ResultCustomizer
rscGQLRequest :: GQLReqOutgoing
rscResponsePaths :: IntMap ResponsePath
..} Object
response =
  IntMap ResponsePath
-> (ResponsePath -> m Value) -> m (IntMap Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for IntMap ResponsePath
rscResponsePaths ((ResponsePath -> m Value) -> m (IntMap Value))
-> (ResponsePath -> m Value) -> m (IntMap Value)
forall a b. (a -> b) -> a -> b
$ \(ResponsePath NonEmpty Name
path) ->
    Value -> [Text] -> m Value
go (Object -> Value
AO.Object Object
response) ((Name -> Text) -> [Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Text
G.unName ([Name] -> [Text])
-> (NonEmpty Name -> [Name]) -> NonEmpty Name -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Name -> [Name]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Name -> [Text]) -> NonEmpty Name -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty Name
path)
  where
    go :: AO.Value -> [Text] -> m AO.Value
    go :: Value -> [Text] -> m Value
go Value
value [Text]
path = case [Text]
path of
      [] -> Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value
      Text
k : [Text]
ks -> case Value
value of
        AO.Object Object
obj -> do
          Value
objValue <-
            Text -> Object -> Maybe Value
AO.lookup Text
k Object
obj
              Maybe Value -> m Value -> m Value
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` Text -> m Value
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 (Text
"failed to lookup key '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. ToTxt a => a -> Text
toTxt Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' in response")
          Value -> [Text] -> m Value
go Value
objValue [Text]
ks
        Value
_ ->
          Text -> m Value
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500
            (Text -> m Value) -> Text -> m Value
forall a b. (a -> b) -> a -> b
$ Text
"unexpected non-object json value found while path not empty: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t (f :: * -> *). (ToTxt t, Foldable f) => f t -> Text
commaSeparated [Text]
path

-------------------------------------------------------------------------------
-- Local helpers

-- NOTE: Ideally this should be done at the remote relationship validation
-- layer.
--
-- When validating remote relationships, we should store the validated names so
-- that we don't need to continually re-validate them downstream.
parseGraphQLName :: (MonadError QErr m) => Text -> m G.Name
parseGraphQLName :: forall (m :: * -> *). MonadError QErr m => Text -> m Name
parseGraphQLName Text
txt =
  Text -> Maybe Name
G.mkName Text
txt Maybe Name -> m Name -> m Name
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` (Code -> Text -> m Name
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
RemoteSchemaError (Text -> m Name) -> Text -> m Name
forall a b. (a -> b) -> a -> b
$ Text
errMsg)
  where
    errMsg :: Text
errMsg = Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a valid GraphQL name"

ordJSONValueToGValue :: (MonadError QErr n) => AO.Value -> n (G.Value Void)
ordJSONValueToGValue :: forall (n :: * -> *). MonadError QErr n => Value -> n (Value Void)
ordJSONValueToGValue =
  (ErrorMessage -> n (Value Void))
-> (Value Void -> n (Value Void))
-> Either ErrorMessage (Value Void)
-> n (Value Void)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Code -> Text -> n (Value Void)
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed (Text -> n (Value Void))
-> (ErrorMessage -> Text) -> ErrorMessage -> n (Value Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessage -> Text
fromErrorMessage) Value Void -> n (Value Void)
forall a. a -> n a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorMessage (Value Void) -> n (Value Void))
-> (Value -> Either ErrorMessage (Value Void))
-> Value
-> n (Value Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either ErrorMessage (Value Void)
P.jsonToGraphQL (Value -> Either ErrorMessage (Value Void))
-> (Value -> Value) -> Value -> Either ErrorMessage (Value Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
AO.fromOrdered