parent
93a0403288
commit
4c9264c12c
@ -15,6 +15,8 @@ and this project adheres to
|
||||
- AST transformation should never fail.
|
||||
* Missing variable are assumed to be null.
|
||||
* Invalid (recusrive or non-existing) fragments should be skipped.
|
||||
- Argument value coercion.
|
||||
- Variable value coercion.
|
||||
|
||||
### Changed
|
||||
- `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function
|
||||
|
||||
@ -1,20 +1,22 @@
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Types and functions used for input and result coercion.
|
||||
module Language.GraphQL.Execute.Coerce
|
||||
( VariableValue(..)
|
||||
, coerceInputLiterals
|
||||
, coerceInputLiteral
|
||||
, matchFieldValues
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text.Lazy as Text.Lazy
|
||||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
|
||||
import qualified Data.Set as Set
|
||||
import Data.Scientific (toBoundedInteger, toRealFloat)
|
||||
import Language.GraphQL.AST.Document (Name)
|
||||
import Language.GraphQL.AST.Core
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import Language.GraphQL.Type.Definition
|
||||
|
||||
@ -67,10 +69,10 @@ instance VariableValue Aeson.Value where
|
||||
then Just $ Object resultMap
|
||||
else Nothing
|
||||
where
|
||||
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues
|
||||
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
|
||||
$ Just (objectValue, HashMap.empty)
|
||||
matchFieldValues _ _ Nothing = Nothing
|
||||
matchFieldValues fieldName inputField (Just (objectValue, resultMap)) =
|
||||
matchFieldValues' _ _ Nothing = Nothing
|
||||
matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
|
||||
let (In.InputField _ fieldType _) = inputField
|
||||
insert = flip (HashMap.insert fieldName) resultMap
|
||||
newObjectValue = HashMap.delete fieldName objectValue
|
||||
@ -90,20 +92,38 @@ instance VariableValue Aeson.Value where
|
||||
pure $ coerced : list
|
||||
coerceVariableValue _ _ = Nothing
|
||||
|
||||
-- | Looks up a value by name in the given map, coerces it and inserts into the
|
||||
-- result map. If the coercion fails, returns 'Nothing'. If the value isn't
|
||||
-- given, but a default value is known, inserts the default value into the
|
||||
-- result map. Otherwise it fails with 'Nothing' if the Input Type is a
|
||||
-- Non-Nullable type, or returns the unchanged, original map.
|
||||
matchFieldValues :: forall a
|
||||
. (In.Type -> a -> Maybe Value)
|
||||
-> HashMap Name a
|
||||
-> Name
|
||||
-> In.Type
|
||||
-> Maybe Value
|
||||
-> Maybe (HashMap Name Value)
|
||||
-> Maybe (HashMap Name Value)
|
||||
matchFieldValues coerce values' fieldName type' defaultValue resultMap =
|
||||
case HashMap.lookup fieldName values' of
|
||||
Just variableValue -> coerceRuntimeValue $ coerce type' variableValue
|
||||
Nothing
|
||||
| Just value <- defaultValue ->
|
||||
HashMap.insert fieldName value <$> resultMap
|
||||
| Nothing <- defaultValue
|
||||
, In.isNonNullType type' -> Nothing
|
||||
| otherwise -> resultMap
|
||||
where
|
||||
coerceRuntimeValue (Just Null)
|
||||
| In.isNonNullType type' = Nothing
|
||||
coerceRuntimeValue coercedValue =
|
||||
HashMap.insert fieldName <$> coercedValue <*> resultMap
|
||||
|
||||
-- | Coerces operation arguments according to the input coercion rules for the
|
||||
-- corresponding types.
|
||||
coerceInputLiterals
|
||||
:: HashMap Name In.Type
|
||||
-> HashMap Name Value
|
||||
-> Maybe Subs
|
||||
coerceInputLiterals variableTypes variableValues =
|
||||
foldWithKey operator variableTypes
|
||||
where
|
||||
operator variableName variableType resultMap =
|
||||
HashMap.insert variableName
|
||||
<$> (lookupVariable variableName >>= coerceInputLiteral variableType)
|
||||
<*> resultMap
|
||||
coerceInputLiteral (In.NamedScalarType type') value
|
||||
coerceInputLiteral :: In.Type -> Value -> Maybe Value
|
||||
coerceInputLiteral (In.ScalarBaseType type') value
|
||||
| (String stringValue) <- value
|
||||
, (ScalarType "String" _) <- type' = Just $ String stringValue
|
||||
| (Boolean booleanValue) <- value
|
||||
@ -119,31 +139,20 @@ coerceInputLiterals variableTypes variableValues =
|
||||
, (ScalarType "ID" _) <- type' = Just $ String stringValue
|
||||
| (Int intValue) <- value
|
||||
, (ScalarType "ID" _) <- type' = Just $ decimal intValue
|
||||
coerceInputLiteral (In.NamedEnumType type') (Enum enumValue)
|
||||
| member enumValue type' = Just $ Enum enumValue
|
||||
coerceInputLiteral (In.NamedInputObjectType type') (Object _) =
|
||||
let (In.InputObjectType _ _ inputFields) = type'
|
||||
in Object <$> foldWithKey matchFieldValues inputFields
|
||||
coerceInputLiteral _ _ = Nothing
|
||||
member value (EnumType _ _ members) = Set.member value members
|
||||
matchFieldValues fieldName (In.InputField _ type' defaultValue) resultMap =
|
||||
case lookupVariable fieldName of
|
||||
Just Null
|
||||
| In.isNonNullType type' -> Nothing
|
||||
| otherwise ->
|
||||
HashMap.insert fieldName Null <$> resultMap
|
||||
Just variableValue -> HashMap.insert fieldName
|
||||
<$> coerceInputLiteral type' variableValue
|
||||
<*> resultMap
|
||||
Nothing
|
||||
| Just value <- defaultValue ->
|
||||
HashMap.insert fieldName value <$> resultMap
|
||||
| Nothing <- defaultValue
|
||||
, In.isNonNullType type' -> Nothing
|
||||
| otherwise -> resultMap
|
||||
lookupVariable = flip HashMap.lookup variableValues
|
||||
foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty)
|
||||
where
|
||||
decimal = String
|
||||
. Text.Lazy.toStrict
|
||||
. Text.Builder.toLazyText
|
||||
. Text.Builder.decimal
|
||||
coerceInputLiteral (In.EnumBaseType type') (Enum enumValue)
|
||||
| member enumValue type' = Just $ Enum enumValue
|
||||
where
|
||||
member value (EnumType _ _ members) = Set.member value members
|
||||
coerceInputLiteral (In.InputObjectBaseType type') (Object values) =
|
||||
let (In.InputObjectType _ _ inputFields) = type'
|
||||
in Object
|
||||
<$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields
|
||||
where
|
||||
matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) =
|
||||
matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue
|
||||
coerceInputLiteral _ _ = Nothing
|
||||
|
||||
@ -19,17 +19,23 @@ import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Sequence as Seq
|
||||
import Language.GraphQL.AST.Document (Name)
|
||||
import Language.GraphQL.AST.Core
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Execute.Transform
|
||||
import Language.GraphQL.Trans
|
||||
import Language.GraphQL.Type.Definition
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema
|
||||
|
||||
resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
|
||||
resolveFieldValue result (Field _ _ args _) =
|
||||
flip runReaderT (Context {arguments=args, values=result})
|
||||
resolveFieldValue :: Monad m
|
||||
=> Definition.Value
|
||||
-> Definition.Subs
|
||||
-> ActionT m a
|
||||
-> m (Either Text a)
|
||||
resolveFieldValue result args =
|
||||
flip runReaderT (Context {arguments = Arguments args, values = result})
|
||||
. runExceptT
|
||||
. runActionT
|
||||
|
||||
@ -54,10 +60,10 @@ aliasOrName (Field alias name _ _) = fromMaybe name alias
|
||||
|
||||
resolveAbstractType :: Monad m
|
||||
=> AbstractType m
|
||||
-> HashMap Name Value
|
||||
-> HashMap Name Definition.Value
|
||||
-> CollectErrsT m (Maybe (Out.ObjectType m))
|
||||
resolveAbstractType abstractType values'
|
||||
| Just (String typeName) <- HashMap.lookup "__typename" values' = do
|
||||
| Just (Definition.String typeName) <- HashMap.lookup "__typename" values' = do
|
||||
types' <- gets types
|
||||
case HashMap.lookup typeName types' of
|
||||
Just (ObjectType objectType) ->
|
||||
@ -97,13 +103,17 @@ instanceOf objectType (AbstractUnionType unionType) =
|
||||
in acc || this == that
|
||||
|
||||
executeField :: Monad m
|
||||
=> Value
|
||||
=> Definition.Value
|
||||
-> Out.Resolver m
|
||||
-> Field m
|
||||
-> CollectErrsT m Aeson.Value
|
||||
executeField prev (Out.Resolver fieldDefinition resolver) field = do
|
||||
let Out.Field _ fieldType _ = fieldDefinition
|
||||
answer <- lift $ resolveFieldValue prev field resolver
|
||||
let Out.Field _ fieldType argumentDefinitions = fieldDefinition
|
||||
let Field _ _ arguments' _ = field
|
||||
case coerceArgumentValues argumentDefinitions arguments' of
|
||||
Nothing -> errmsg "Argument coercing failed."
|
||||
Just argumentValues -> do
|
||||
answer <- lift $ resolveFieldValue prev argumentValues resolver
|
||||
case answer of
|
||||
Right result -> completeValue fieldType field result
|
||||
Left errorMessage -> errmsg errorMessage
|
||||
@ -111,26 +121,26 @@ executeField prev (Out.Resolver fieldDefinition resolver) field = do
|
||||
completeValue :: Monad m
|
||||
=> Out.Type m
|
||||
-> Field m
|
||||
-> Value
|
||||
-> Definition.Value
|
||||
-> CollectErrsT m Aeson.Value
|
||||
completeValue _ _ Null = pure Aeson.Null
|
||||
completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
|
||||
completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
|
||||
completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
|
||||
completeValue _ _ (Enum enum) = pure $ Aeson.String enum
|
||||
completeValue _ _ (String string') = pure $ Aeson.String string'
|
||||
completeValue _ _ Definition.Null = pure Aeson.Null
|
||||
completeValue _ _ (Definition.Int integer) = pure $ Aeson.toJSON integer
|
||||
completeValue _ _ (Definition.Boolean boolean') = pure $ Aeson.Bool boolean'
|
||||
completeValue _ _ (Definition.Float float') = pure $ Aeson.toJSON float'
|
||||
completeValue _ _ (Definition.Enum enum) = pure $ Aeson.String enum
|
||||
completeValue _ _ (Definition.String string') = pure $ Aeson.String string'
|
||||
completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
|
||||
executeSelectionSet result objectType seqSelection
|
||||
completeValue (Out.ListBaseType listType) selectionField (List list) =
|
||||
completeValue (Out.ListBaseType listType) selectionField (Definition.List list) =
|
||||
Aeson.toJSON <$> traverse (completeValue listType selectionField) list
|
||||
completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result
|
||||
| Object objectMap <- result = do
|
||||
| Definition.Object objectMap <- result = do
|
||||
abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap
|
||||
case abstractType of
|
||||
Just objectType -> executeSelectionSet result objectType seqSelection
|
||||
Nothing -> errmsg "Value completion failed."
|
||||
completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result
|
||||
| Object objectMap <- result = do
|
||||
| Definition.Object objectMap <- result = do
|
||||
abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap
|
||||
case abstractType of
|
||||
Just objectType -> executeSelectionSet result objectType seqSelection
|
||||
@ -144,7 +154,7 @@ errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
|
||||
-- to each 'Selection'. Resolves into a value containing the resolved
|
||||
-- 'Selection', or a null value and error information.
|
||||
executeSelectionSet :: Monad m
|
||||
=> Value
|
||||
=> Definition.Value
|
||||
-> Out.ObjectType m
|
||||
-> Seq (Selection m)
|
||||
-> CollectErrsT m Aeson.Value
|
||||
@ -161,3 +171,38 @@ executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selection
|
||||
| Just typeField <- lookupResolver name =
|
||||
executeField result typeField fld
|
||||
| otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
|
||||
|
||||
coerceArgumentValues
|
||||
:: HashMap Name In.Argument
|
||||
-> HashMap Name Input
|
||||
-> Maybe Definition.Subs
|
||||
coerceArgumentValues argumentDefinitions argumentValues =
|
||||
HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions
|
||||
where
|
||||
forEach variableName (In.Argument _ variableType defaultValue) =
|
||||
matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue
|
||||
coerceArgumentValue inputType (Int integer) =
|
||||
coerceInputLiteral inputType (Definition.Int integer)
|
||||
coerceArgumentValue inputType (Boolean boolean) =
|
||||
coerceInputLiteral inputType (Definition.Boolean boolean)
|
||||
coerceArgumentValue inputType (String string) =
|
||||
coerceInputLiteral inputType (Definition.String string)
|
||||
coerceArgumentValue inputType (Float float) =
|
||||
coerceInputLiteral inputType (Definition.Float float)
|
||||
coerceArgumentValue inputType (Enum enum) =
|
||||
coerceInputLiteral inputType (Definition.Enum enum)
|
||||
coerceArgumentValue inputType Null
|
||||
| In.isNonNullType inputType = Nothing
|
||||
| otherwise = coerceInputLiteral inputType Definition.Null
|
||||
coerceArgumentValue (In.ListBaseType inputType) (List list) =
|
||||
let coerceItem = coerceInputLiteral inputType
|
||||
in Definition.List <$> traverse coerceItem list
|
||||
coerceArgumentValue (In.InputObjectBaseType inputType) (Object object)
|
||||
| In.InputObjectType _ _ inputFields <- inputType =
|
||||
let go = forEachField object
|
||||
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
|
||||
in Definition.Object <$> resultMap
|
||||
coerceArgumentValue _ (Variable variable) = pure variable
|
||||
coerceArgumentValue _ _ = Nothing
|
||||
forEachField object variableName (In.InputField _ variableType defaultValue) =
|
||||
matchFieldValues coerceArgumentValue object variableName variableType defaultValue
|
||||
|
||||
@ -18,11 +18,12 @@
|
||||
-- the original AST.
|
||||
module Language.GraphQL.Execute.Transform
|
||||
( Document(..)
|
||||
, Fragment(..)
|
||||
, QueryError(..)
|
||||
, Operation(..)
|
||||
, Selection(..)
|
||||
, Field(..)
|
||||
, Fragment(..)
|
||||
, Input(..)
|
||||
, Operation(..)
|
||||
, QueryError(..)
|
||||
, Selection(..)
|
||||
, document
|
||||
, queryError
|
||||
) where
|
||||
@ -34,6 +35,7 @@ import Data.Foldable (find)
|
||||
import Data.Functor.Identity (Identity(..))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Int (Int32)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
@ -43,19 +45,18 @@ import qualified Data.Text as Text
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import Language.GraphQL.AST.Core
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Type.Directive (Directive(..))
|
||||
import qualified Language.GraphQL.Type.Directive as Directive
|
||||
import Language.GraphQL.Type.Definition (Subs, Value(..))
|
||||
import qualified Language.GraphQL.AST.Core as Core
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import qualified Language.GraphQL.Type.Directive as Core
|
||||
import Language.GraphQL.Type.Schema
|
||||
|
||||
-- | Associates a fragment name with a list of 'Core.Field's.
|
||||
-- | Associates a fragment name with a list of 'Field's.
|
||||
data Replacement m = Replacement
|
||||
{ fragments :: HashMap Full.Name (Fragment m)
|
||||
, fragmentDefinitions :: FragmentDefinitions
|
||||
, variableValues :: Subs
|
||||
, variableValues :: Definition.Subs
|
||||
, types :: HashMap Full.Name (Type m)
|
||||
}
|
||||
|
||||
@ -78,7 +79,8 @@ data Operation m
|
||||
| Mutation (Maybe Text) (Seq (Selection m))
|
||||
|
||||
-- | Single GraphQL field.
|
||||
data Field m = Field (Maybe Full.Name) Full.Name Arguments (Seq (Selection m))
|
||||
data Field m = Field
|
||||
(Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
|
||||
|
||||
-- | Contains the operation to be executed along with its root type.
|
||||
data Document m = Document
|
||||
@ -100,6 +102,18 @@ data QueryError
|
||||
| EmptyDocument
|
||||
| UnsupportedRootOperation
|
||||
|
||||
data Input
|
||||
= Int Int32
|
||||
| Float Double
|
||||
| String Text
|
||||
| Boolean Bool
|
||||
| Null
|
||||
| Enum Name
|
||||
| List [Definition.Value]
|
||||
| Object (HashMap Name Input)
|
||||
| Variable Definition.Value
|
||||
deriving (Eq, Show)
|
||||
|
||||
queryError :: QueryError -> Text
|
||||
queryError (OperationNotFound operationName) = Text.unwords
|
||||
["Operation", operationName, "couldn't be found in the document."]
|
||||
@ -158,41 +172,33 @@ coerceVariableValues :: VariableValue a
|
||||
. HashMap Full.Name (Type m)
|
||||
-> OperationDefinition
|
||||
-> HashMap.HashMap Full.Name a
|
||||
-> Either QueryError Subs
|
||||
coerceVariableValues types operationDefinition variableValues' =
|
||||
-> Either QueryError Definition.Subs
|
||||
coerceVariableValues types operationDefinition variableValues =
|
||||
let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
|
||||
in maybe (Left CoercionError) Right
|
||||
$ foldr coerceValue (Just HashMap.empty) variableDefinitions
|
||||
$ foldr forEach (Just HashMap.empty) variableDefinitions
|
||||
where
|
||||
coerceValue variableDefinition coercedValues = do
|
||||
forEach variableDefinition coercedValues = do
|
||||
let Full.VariableDefinition variableName variableTypeName defaultValue =
|
||||
variableDefinition
|
||||
let defaultValue' = constValue <$> defaultValue
|
||||
let value' = HashMap.lookup variableName variableValues'
|
||||
|
||||
variableType <- lookupInputType variableTypeName types
|
||||
HashMap.insert variableName
|
||||
<$> choose value' defaultValue' variableType
|
||||
<*> coercedValues
|
||||
choose Nothing defaultValue variableType
|
||||
| Just _ <- defaultValue = defaultValue
|
||||
| not (In.isNonNullType variableType) = Just Null
|
||||
choose (Just value') _ variableType
|
||||
| Just coercedValue <- coerceVariableValue variableType value'
|
||||
, not (In.isNonNullType variableType) || coercedValue /= Null =
|
||||
Just coercedValue
|
||||
choose _ _ _ = Nothing
|
||||
|
||||
constValue :: Full.ConstValue -> Value
|
||||
constValue (Full.ConstInt i) = Int i
|
||||
constValue (Full.ConstFloat f) = Float f
|
||||
constValue (Full.ConstString x) = String x
|
||||
constValue (Full.ConstBoolean b) = Boolean b
|
||||
constValue Full.ConstNull = Null
|
||||
constValue (Full.ConstEnum e) = Enum e
|
||||
constValue (Full.ConstList l) = List $ constValue <$> l
|
||||
matchFieldValues coerceVariableValue' variableValues variableName variableType defaultValue' coercedValues
|
||||
coerceVariableValue' variableType value'
|
||||
= coerceVariableValue variableType value'
|
||||
>>= coerceInputLiteral variableType
|
||||
|
||||
constValue :: Full.ConstValue -> Definition.Value
|
||||
constValue (Full.ConstInt i) = Definition.Int i
|
||||
constValue (Full.ConstFloat f) = Definition.Float f
|
||||
constValue (Full.ConstString x) = Definition.String x
|
||||
constValue (Full.ConstBoolean b) = Definition.Boolean b
|
||||
constValue Full.ConstNull = Definition.Null
|
||||
constValue (Full.ConstEnum e) = Definition.Enum e
|
||||
constValue (Full.ConstList l) = Definition.List $ constValue <$> l
|
||||
constValue (Full.ConstObject o) =
|
||||
Object $ HashMap.fromList $ constObjectField <$> o
|
||||
Definition.Object $ HashMap.fromList $ constObjectField <$> o
|
||||
where
|
||||
constObjectField (Full.ObjectField key value') = (key, constValue value')
|
||||
|
||||
@ -271,11 +277,15 @@ selection
|
||||
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
||||
selection (Full.Field alias name arguments' directives' selections) =
|
||||
maybe (Left mempty) (Right . SelectionField) <$> do
|
||||
fieldArguments <- arguments arguments'
|
||||
fieldArguments <- foldM go HashMap.empty arguments'
|
||||
fieldSelections <- appendSelection selections
|
||||
fieldDirectives <- Directive.selection <$> directives directives'
|
||||
let field' = Field alias name fieldArguments fieldSelections
|
||||
pure $ field' <$ fieldDirectives
|
||||
where
|
||||
go arguments (Full.Argument name' value') =
|
||||
inputField arguments name' value'
|
||||
|
||||
selection (Full.FragmentSpread name directives') =
|
||||
maybe (Left mempty) (Right . SelectionFragment) <$> do
|
||||
spreadDirectives <- Directive.selection <$> directives directives'
|
||||
@ -320,11 +330,15 @@ appendSelection = foldM go mempty
|
||||
append acc (Left list) = list >< acc
|
||||
append acc (Right one) = one <| acc
|
||||
|
||||
directives :: [Full.Directive] -> State (Replacement m) [Core.Directive]
|
||||
directives :: [Full.Directive] -> State (Replacement m) [Directive]
|
||||
directives = traverse directive
|
||||
where
|
||||
directive (Full.Directive directiveName directiveArguments) =
|
||||
Core.Directive directiveName <$> arguments directiveArguments
|
||||
directive (Full.Directive directiveName directiveArguments)
|
||||
= Directive directiveName . Arguments
|
||||
<$> foldM go HashMap.empty directiveArguments
|
||||
go arguments (Full.Argument name value') = do
|
||||
substitutedValue <- value value'
|
||||
return $ HashMap.insert name substitutedValue arguments
|
||||
|
||||
-- * Fragment replacement
|
||||
|
||||
@ -371,27 +385,45 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
|
||||
let newFragments = HashMap.insert name newValue fragments
|
||||
in replacement{ fragments = newFragments }
|
||||
|
||||
arguments :: [Full.Argument] -> State (Replacement m) Core.Arguments
|
||||
arguments = fmap Core.Arguments . foldM go HashMap.empty
|
||||
where
|
||||
go arguments' (Full.Argument name value') = do
|
||||
substitutedValue <- value value'
|
||||
return $ HashMap.insert name substitutedValue arguments'
|
||||
|
||||
value :: Full.Value -> State (Replacement m) Value
|
||||
value :: forall m. Full.Value -> State (Replacement m) Definition.Value
|
||||
value (Full.Variable name) =
|
||||
gets $ fromMaybe Null . HashMap.lookup name . variableValues
|
||||
value (Full.Int i) = pure $ Int i
|
||||
value (Full.Float f) = pure $ Float f
|
||||
value (Full.String x) = pure $ String x
|
||||
value (Full.Boolean b) = pure $ Boolean b
|
||||
value Full.Null = pure Null
|
||||
value (Full.Enum e) = pure $ Enum e
|
||||
value (Full.List l) = List <$> traverse value l
|
||||
gets (fromMaybe Definition.Null . HashMap.lookup name . variableValues)
|
||||
value (Full.Int i) = pure $ Definition.Int i
|
||||
value (Full.Float f) = pure $ Definition.Float f
|
||||
value (Full.String x) = pure $ Definition.String x
|
||||
value (Full.Boolean b) = pure $ Definition.Boolean b
|
||||
value Full.Null = pure Definition.Null
|
||||
value (Full.Enum e) = pure $ Definition.Enum e
|
||||
value (Full.List l) = Definition.List <$> traverse value l
|
||||
value (Full.Object o) =
|
||||
Object . HashMap.fromList <$> traverse objectField o
|
||||
Definition.Object . HashMap.fromList <$> traverse objectField o
|
||||
where
|
||||
objectField (Full.ObjectField name value') = (name,) <$> value value'
|
||||
|
||||
objectField
|
||||
:: Full.ObjectField Full.Value
|
||||
-> State (Replacement m) (Full.Name, Value)
|
||||
objectField (Full.ObjectField name value') = (name,) <$> value value'
|
||||
input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
|
||||
input (Full.Variable name) =
|
||||
gets (fmap Variable . HashMap.lookup name . variableValues)
|
||||
input (Full.Int i) = pure $ pure $ Int i
|
||||
input (Full.Float f) = pure $ pure $ Float f
|
||||
input (Full.String x) = pure $ pure $ String x
|
||||
input (Full.Boolean b) = pure $ pure $ Boolean b
|
||||
input Full.Null = pure $ pure Null
|
||||
input (Full.Enum e) = pure $ pure $ Enum e
|
||||
input (Full.List list) = pure . List <$> traverse value list
|
||||
input (Full.Object object) = do
|
||||
objectFields <- foldM objectField HashMap.empty object
|
||||
pure $ pure $ Object objectFields
|
||||
where
|
||||
objectField resultMap (Full.ObjectField name value') =
|
||||
inputField resultMap name value'
|
||||
|
||||
inputField :: forall m
|
||||
. HashMap Full.Name Input
|
||||
-> Full.Name
|
||||
-> Full.Value
|
||||
-> State (Replacement m) (HashMap Full.Name Input)
|
||||
inputField resultMap name value' = do
|
||||
objectFieldValue <- input value'
|
||||
case objectFieldValue of
|
||||
Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap
|
||||
Nothing -> pure resultMap
|
||||
|
||||
@ -6,12 +6,10 @@ module Language.GraphQL.Execute.CoerceSpec
|
||||
import Data.Aeson as Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Scientific (scientific)
|
||||
import qualified Data.Set as Set
|
||||
import Language.GraphQL.AST.Document (Name)
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Type.Definition
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
@ -22,14 +20,6 @@ direction :: EnumType
|
||||
direction = EnumType "Direction" Nothing
|
||||
$ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"]
|
||||
|
||||
coerceInputLiteral :: In.Type -> Value -> Maybe Subs
|
||||
coerceInputLiteral input value = coerceInputLiterals
|
||||
(HashMap.singleton "variableName" input)
|
||||
(HashMap.singleton "variableName" value)
|
||||
|
||||
lookupActual :: Maybe (HashMap Name Value) -> Maybe Value
|
||||
lookupActual = (HashMap.lookup "variableName" =<<)
|
||||
|
||||
singletonInputObject :: In.Type
|
||||
singletonInputObject = In.NamedInputObjectType type'
|
||||
where
|
||||
@ -39,7 +29,7 @@ singletonInputObject = In.NamedInputObjectType type'
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "ToGraphQL Aeson" $ do
|
||||
describe "VariableValue Aeson" $ do
|
||||
it "coerces strings" $
|
||||
let expected = Just (String "asdf")
|
||||
actual = coerceVariableValue
|
||||
@ -107,7 +97,7 @@ spec = do
|
||||
let expected = Just (Enum "NORTH")
|
||||
actual = coerceInputLiteral
|
||||
(In.NamedEnumType direction) (Enum "NORTH")
|
||||
in lookupActual actual `shouldBe` expected
|
||||
in actual `shouldBe` expected
|
||||
it "fails with non-existing enum value" $
|
||||
let actual = coerceInputLiteral
|
||||
(In.NamedEnumType direction) (Enum "NORTH_EAST")
|
||||
@ -115,4 +105,4 @@ spec = do
|
||||
it "coerces integers to IDs" $
|
||||
let expected = Just (String "1234")
|
||||
actual = coerceInputLiteral (In.NamedScalarType id) (Int 1234)
|
||||
in lookupActual actual `shouldBe` expected
|
||||
in actual `shouldBe` expected
|
||||
|
||||
@ -11,10 +11,12 @@ import Data.Functor.Identity (Identity)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Set as Set
|
||||
import Language.GraphQL.Trans
|
||||
import Language.GraphQL.Type.Definition
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema
|
||||
import Language.GraphQL.Type.Schema (Schema(..))
|
||||
import Test.StarWars.Data
|
||||
import Prelude hiding (id)
|
||||
|
||||
@ -24,10 +26,17 @@ schema :: Schema Identity
|
||||
schema = Schema { query = queryType, mutation = Nothing }
|
||||
where
|
||||
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
[ ("hero", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) hero)
|
||||
, ("human", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) human)
|
||||
, ("droid", Out.Resolver (Out.Field Nothing (Out.NamedObjectType droidObject) mempty) droid)
|
||||
[ ("hero", Out.Resolver heroField hero)
|
||||
, ("human", Out.Resolver humanField human)
|
||||
, ("droid", Out.Resolver droidField droid)
|
||||
]
|
||||
heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
|
||||
$ HashMap.singleton "episode"
|
||||
$ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
|
||||
humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
|
||||
$ HashMap.singleton "id"
|
||||
$ In.Argument Nothing (In.NonNullScalarType string) Nothing
|
||||
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
|
||||
|
||||
heroObject :: Out.ObjectType Identity
|
||||
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
|
||||
@ -76,6 +85,10 @@ idField f = do
|
||||
let (Object v') = v
|
||||
pure $ v' HashMap.! f
|
||||
|
||||
episodeEnum :: EnumType
|
||||
episodeEnum = EnumType "Episode" Nothing
|
||||
$ Set.fromList ["NEW_HOPE", "EMPIRE", "JEDI"]
|
||||
|
||||
hero :: ActionT Identity Value
|
||||
hero = do
|
||||
episode <- argument "episode"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user