Coerce result

Fixes #45.
This commit is contained in:
Eugen Wissner 2020-06-13 07:20:19 +02:00
parent e8c54810f8
commit 882276a845
10 changed files with 278 additions and 184 deletions

View File

@ -61,7 +61,7 @@ Next we define our query.
To run the query, we call the `graphql` with the schema and the query.
> main1 :: IO ()
> main1 = putStrLn =<< encode <$> graphql schema1 query1
> main1 = graphql schema1 query1 >>= putStrLn . encode
This runs the query by fetching the one field defined,
returning
@ -99,7 +99,7 @@ Next we define our query.
> query2 = "{ time }"
>
> main2 :: IO ()
> main2 = putStrLn =<< encode <$> graphql schema2 query2
> main2 = graphql schema2 query2 >>= putStrLn . encode
This runs the query, returning the current time
@ -154,7 +154,7 @@ Now that we have two resolvers, we can define a schema which uses them both.
> query3 = "query timeAndHello { time hello }"
>
> main3 :: IO ()
> main3 = putStrLn =<< encode <$> graphql schema3 query3
> main3 = graphql schema3 query3 >>= putStrLn . encode
This queries for both time and hello, returning

View File

@ -14,7 +14,7 @@ import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Execution
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
@ -68,4 +68,4 @@ executeOperation :: Monad m
-> Seq (Transform.Selection m)
-> m Aeson.Value
executeOperation types' objectType fields =
runCollectErrs types' $ executeSelectionSet Null objectType fields
runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields

View File

@ -3,21 +3,28 @@
-- | Types and functions used for input and result coercion.
module Language.GraphQL.Execute.Coerce
( VariableValue(..)
( Output(..)
, Serialize(..)
, VariableValue(..)
, coerceInputLiteral
, matchFieldValues
) where
import qualified Data.Aeson as Aeson
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Map.Strict (Map)
import Data.String (IsString(..))
import Data.Text (Text)
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 Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST (Name)
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
-- | Since variables are passed separately from the query, in an independent
-- format, they should be first coerced to the internal representation used by
@ -46,26 +53,26 @@ class VariableValue a where
coerceVariableValue
:: In.Type -- ^ Expected type (variable type given in the query).
-> a -- ^ Variable value being coerced.
-> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise.
-> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise.
instance VariableValue Aeson.Value where
coerceVariableValue _ Aeson.Null = Just Null
coerceVariableValue _ Aeson.Null = Just Type.Null
coerceVariableValue (In.ScalarBaseType scalarType) value
| (Aeson.String stringValue) <- value = Just $ String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue
| (Aeson.String stringValue) <- value = Just $ Type.String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
| (Aeson.Number numberValue) <- value
, (ScalarType "Float" _) <- scalarType =
Just $ Float $ toRealFloat numberValue
, (Type.ScalarType "Float" _) <- scalarType =
Just $ Type.Float $ toRealFloat numberValue
| (Aeson.Number numberValue) <- value = -- ID or Int
Int <$> toBoundedInteger numberValue
Type.Int <$> toBoundedInteger numberValue
coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
Just $ Enum stringValue
Just $ Type.Enum stringValue
coerceVariableValue (In.InputObjectBaseType objectType) value
| (Aeson.Object objectValue) <- value = do
let (In.InputObjectType _ _ inputFields) = objectType
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if HashMap.null newObjectValue
then Just $ Object resultMap
then Just $ Type.Object resultMap
else Nothing
where
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
@ -81,8 +88,8 @@ instance VariableValue Aeson.Value where
pure (newObjectValue, insert coerced)
Nothing -> Just (objectValue, resultMap)
coerceVariableValue (In.ListBaseType listType) value
| (Aeson.Array arrayValue) <- value = List
<$> foldr foldVector (Just []) arrayValue
| (Aeson.Array arrayValue) <- value =
Type.List <$> foldr foldVector (Just []) arrayValue
| otherwise = coerceVariableValue listType value
where
foldVector _ Nothing = Nothing
@ -97,13 +104,13 @@ instance VariableValue Aeson.Value where
-- 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)
. (In.Type -> a -> Maybe Type.Value)
-> HashMap Name a
-> Name
-> In.Type
-> Maybe Value
-> Maybe (HashMap Name Value)
-> Maybe (HashMap Name Value)
-> Maybe Type.Value
-> Maybe (HashMap Name Type.Value)
-> Maybe (HashMap Name Type.Value)
matchFieldValues coerce values' fieldName type' defaultValue resultMap =
case HashMap.lookup fieldName values' of
Just variableValue -> coerceRuntimeValue $ coerce type' variableValue
@ -114,44 +121,99 @@ matchFieldValues coerce values' fieldName type' defaultValue resultMap =
, In.isNonNullType type' -> Nothing
| otherwise -> resultMap
where
coerceRuntimeValue (Just Null)
coerceRuntimeValue (Just Type.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.
coerceInputLiteral :: In.Type -> Value -> Maybe Value
coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value
coerceInputLiteral (In.ScalarBaseType type') value
| (String stringValue) <- value
, (ScalarType "String" _) <- type' = Just $ String stringValue
| (Boolean booleanValue) <- value
, (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue
| (Int intValue) <- value
, (ScalarType "Int" _) <- type' = Just $ Int intValue
| (Float floatValue) <- value
, (ScalarType "Float" _) <- type' = Just $ Float floatValue
| (Int intValue) <- value
, (ScalarType "Float" _) <- type' =
Just $ Float $ fromIntegral intValue
| (String stringValue) <- value
, (ScalarType "ID" _) <- type' = Just $ String stringValue
| (Int intValue) <- value
, (ScalarType "ID" _) <- type' = Just $ decimal intValue
| (Type.String stringValue) <- value
, (Type.ScalarType "String" _) <- type' = Just $ Type.String stringValue
| (Type.Boolean booleanValue) <- value
, (Type.ScalarType "Boolean" _) <- type' = Just $ Type.Boolean booleanValue
| (Type.Int intValue) <- value
, (Type.ScalarType "Int" _) <- type' = Just $ Type.Int intValue
| (Type.Float floatValue) <- value
, (Type.ScalarType "Float" _) <- type' = Just $ Type.Float floatValue
| (Type.Int intValue) <- value
, (Type.ScalarType "Float" _) <- type' =
Just $ Type.Float $ fromIntegral intValue
| (Type.String stringValue) <- value
, (Type.ScalarType "ID" _) <- type' = Just $ Type.String stringValue
| (Type.Int intValue) <- value
, (Type.ScalarType "ID" _) <- type' = Just $ decimal intValue
where
decimal = String
decimal = Type.String
. Text.Lazy.toStrict
. Text.Builder.toLazyText
. Text.Builder.decimal
coerceInputLiteral (In.EnumBaseType type') (Enum enumValue)
| member enumValue type' = Just $ Enum enumValue
coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)
| member enumValue type' = Just $ Type.Enum enumValue
where
member value (EnumType _ _ members) = HashMap.member value members
coerceInputLiteral (In.InputObjectBaseType type') (Object values) =
member value (Type.EnumType _ _ members) = HashMap.member value members
coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) =
let (In.InputObjectType _ _ inputFields) = type'
in Object
in Type.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
-- | 'Serialize' describes how a @GraphQL@ value should be serialized.
class Serialize a where
-- | Serializes a @GraphQL@ value according to the given serialization
-- format.
--
-- Type infomration is given as a hint, e.g. if you need to know what type
-- is being serialized to serialize it properly. Don't do any validation for
-- @GraphQL@ built-in types here.
--
-- If the value cannot be serialized without losing information, return
-- 'Nothing' — it will cause a field error.
serialize :: forall m
. Out.Type m -- ^ Expected output type.
-> Output a -- ^ The value to be serialized.
-> Maybe a -- ^ Serialized value on success or 'Nothing'.
-- | __null__ representation in the given serialization format.
null :: a
-- | Intermediate type used to serialize a @GraphQL@ value.
--
-- The serialization is done during the execution, and 'Output' contains
-- already serialized data (in 'List' and 'Object') as well as the new layer
-- that has to be serialized in the current step. So 'Output' is parameterized
-- by the serialization format.
data Output a
= Int Int32
| Float Double
| String Text
| Boolean Bool
| Enum Name
| List [a]
| Object (Map Name a)
deriving (Eq, Show)
instance forall a. IsString (Output a) where
fromString = String . fromString
instance Serialize Aeson.Value where
serialize (Out.ScalarBaseType scalarType) value
| Type.ScalarType "Int" _ <- scalarType
, Int int <- value = Just $ Aeson.toJSON int
| Type.ScalarType "Float" _ <- scalarType
, Float float <- value = Just $ Aeson.toJSON float
| Type.ScalarType "String" _ <- scalarType
, String string <- value = Just $ Aeson.String string
| Type.ScalarType "ID" _ <- scalarType
, String string <- value = Just $ Aeson.String string
| Type.ScalarType "Boolean" _ <- scalarType
, Boolean boolean <- value = Just $ Aeson.Bool boolean
serialize _ (Enum enum) = Just $ Aeson.String enum
serialize _ (List list) = Just $ Aeson.toJSON list
serialize _ (Object object) = Just $ Aeson.toJSON object
serialize _ _ = Nothing
null = Aeson.Null

View File

@ -1,11 +1,11 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Language.GraphQL.Execute.Execution
( executeSelectionSet
) where
import qualified Data.Aeson as Aeson
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
@ -22,16 +22,17 @@ import Language.GraphQL.AST (Name)
import Language.GraphQL.AST.Core
import Language.GraphQL.Error
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Transform
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Trans
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
import Prelude hiding (null)
resolveFieldValue :: Monad m
=> Definition.Value
-> Definition.Subs
=> Type.Value
-> Type.Subs
-> ActionT m a
-> m (Either Text a)
resolveFieldValue result args =
@ -41,29 +42,29 @@ resolveFieldValue result args =
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Selection m)
-> Map Name (NonEmpty (Field m))
-> Seq (Transform.Selection m)
-> Map Name (NonEmpty (Transform.Field m))
collectFields objectType = foldl forEach Map.empty
where
forEach groupedFields (SelectionField field) =
forEach groupedFields (Transform.SelectionField field) =
let responseKey = aliasOrName field
in Map.insertWith (<>) responseKey (field :| []) groupedFields
forEach groupedFields (SelectionFragment selectionFragment)
| Fragment fragmentType fragmentSelectionSet <- selectionFragment
forEach groupedFields (Transform.SelectionFragment selectionFragment)
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
, doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
| otherwise = groupedFields
aliasOrName :: forall m. Field m -> Name
aliasOrName (Field alias name _ _) = fromMaybe name alias
aliasOrName :: forall m. Transform.Field m -> Name
aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
resolveAbstractType :: Monad m
=> AbstractType m
-> HashMap Name Definition.Value
-> Type.Subs
-> CollectErrsT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values'
| Just (Definition.String typeName) <- HashMap.lookup "__typename" values' = do
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
types' <- gets types
case HashMap.lookup typeName types' of
Just (ObjectType objectType) ->
@ -97,14 +98,14 @@ instanceOf objectType (AbstractUnionType unionType) =
where
go unionMemberType acc = acc || objectType == unionMemberType
executeField :: Monad m
executeField :: (Monad m, Serialize a)
=> Out.Resolver m
-> Definition.Value
-> NonEmpty (Field m)
-> CollectErrsT m Aeson.Value
-> Type.Value
-> NonEmpty (Transform.Field m)
-> CollectErrsT m a
executeField (Out.Resolver fieldDefinition resolver) prev fields = do
let Out.Field _ fieldType argumentDefinitions = fieldDefinition
let (Field _ _ arguments' _ :| []) = fields
let (Transform.Field _ _ arguments' _ :| []) = fields
case coerceArgumentValues argumentDefinitions arguments' of
Nothing -> errmsg "Argument coercing failed."
Just argumentValues -> do
@ -113,61 +114,80 @@ executeField (Out.Resolver fieldDefinition resolver) prev fields = do
Right result -> completeValue fieldType fields result
Left errorMessage -> errmsg errorMessage
completeValue :: Monad m
completeValue :: (Monad m, Serialize a)
=> Out.Type m
-> NonEmpty (Field m)
-> Definition.Value
-> CollectErrsT m Aeson.Value
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.ListBaseType listType) fields (Definition.List list) =
Aeson.toJSON <$> traverse (completeValue listType fields) list
-> NonEmpty (Transform.Field m)
-> Type.Value
-> CollectErrsT m a
completeValue (Out.isNonNullType -> False) _ Type.Null = pure null
completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)
= traverse (completeValue listType fields) list
>>= coerceResult outputType . List
completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) =
coerceResult outputType $ Int int
completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) =
coerceResult outputType $ Boolean boolean
completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
coerceResult outputType $ Float float
completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
coerceResult outputType $ String string
completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers
then coerceResult outputType $ Enum enum
else errmsg "Value completion failed."
completeValue (Out.ObjectBaseType objectType) fields result =
executeSelectionSet result objectType $ mergeSelectionSets fields
completeValue (Out.InterfaceBaseType interfaceType) fields result
| Definition.Object objectMap <- result = do
abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap
case abstractType of
| Type.Object objectMap <- result = do
let abstractType = AbstractInterfaceType interfaceType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields
Nothing -> errmsg "Value completion failed."
completeValue (Out.UnionBaseType unionType) fields result
| Definition.Object objectMap <- result = do
abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap
case abstractType of
| Type.Object objectMap <- result = do
let abstractType = AbstractUnionType unionType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields
Nothing -> errmsg "Value completion failed."
completeValue _ _ _ = errmsg "Value completion failed."
mergeSelectionSets :: Monad m => NonEmpty (Field m) -> Seq (Selection m)
mergeSelectionSets fields = foldr forEach mempty fields
mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m)
mergeSelectionSets = foldr forEach mempty
where
forEach (Field _ _ _ fieldSelectionSet) selectionSet =
forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
selectionSet <> fieldSelectionSet
errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
errmsg errorMessage = addErrMsg errorMessage >> pure null
-- | Takes an 'Out.ObjectType' and a list of 'Selection's and applies each field
-- to each 'Selection'. Resolves into a value containing the resolved
-- 'Selection', or a null value and error information.
executeSelectionSet :: Monad m
=> Definition.Value
coerceResult :: (Monad m, Serialize a)
=> Out.Type m
-> Output a
-> CollectErrsT m a
coerceResult outputType result
| Just serialized <- serialize outputType result = pure serialized
| otherwise = errmsg "Result coercion failed."
-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
-- each field to each 'Transform.Selection'. Resolves into a value containing
-- the resolved 'Transform.Selection', or a null value and error information.
executeSelectionSet :: (Monad m, Serialize a)
=> Type.Value
-> Out.ObjectType m
-> Seq (Selection m)
-> CollectErrsT m Aeson.Value
-> Seq (Transform.Selection m)
-> CollectErrsT m a
executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
let fields = collectFields objectType selectionSet
resolvedValues <- Map.traverseMaybeWithKey forEach fields
pure $ Aeson.toJSON resolvedValues
coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
where
forEach _ fields@(field :| _) =
let Field _ name _ _ = field
let Transform.Field _ name _ _ = field
in traverse (tryResolver fields) $ lookupResolver name
lookupResolver = flip HashMap.lookup resolvers
tryResolver fields resolver =
@ -175,35 +195,35 @@ executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selection
coerceArgumentValues
:: HashMap Name In.Argument
-> HashMap Name Input
-> Maybe Definition.Subs
-> HashMap Name Transform.Input
-> Maybe Type.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
coerceArgumentValue inputType (Transform.Int integer) =
coerceInputLiteral inputType (Type.Int integer)
coerceArgumentValue inputType (Transform.Boolean boolean) =
coerceInputLiteral inputType (Type.Boolean boolean)
coerceArgumentValue inputType (Transform.String string) =
coerceInputLiteral inputType (Type.String string)
coerceArgumentValue inputType (Transform.Float float) =
coerceInputLiteral inputType (Type.Float float)
coerceArgumentValue inputType (Transform.Enum enum) =
coerceInputLiteral inputType (Type.Enum enum)
coerceArgumentValue inputType Transform.Null
| In.isNonNullType inputType = Nothing
| otherwise = coerceInputLiteral inputType Definition.Null
coerceArgumentValue (In.ListBaseType inputType) (List list) =
| otherwise = coerceInputLiteral inputType Type.Null
coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
let coerceItem = coerceInputLiteral inputType
in Definition.List <$> traverse coerceItem list
coerceArgumentValue (In.InputObjectBaseType inputType) (Object object)
in Type.List <$> traverse coerceItem list
coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.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
in Type.Object <$> resultMap
coerceArgumentValue _ (Transform.Variable variable) = pure variable
coerceArgumentValue _ _ = Nothing
forEachField object variableName (In.InputField _ variableType defaultValue) =
matchFieldValues coerceArgumentValue object variableName variableType defaultValue

View File

@ -45,10 +45,10 @@ import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full
import Language.GraphQL.AST (Name)
import Language.GraphQL.AST.Core
import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Execute.Coerce as Coerce
import Language.GraphQL.Type.Directive (Directive(..))
import qualified Language.GraphQL.Type.Directive as Directive
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
@ -57,7 +57,7 @@ import Language.GraphQL.Type.Schema
data Replacement m = Replacement
{ fragments :: HashMap Full.Name (Fragment m)
, fragmentDefinitions :: FragmentDefinitions
, variableValues :: Definition.Subs
, variableValues :: Type.Subs
, types :: HashMap Full.Name (Type m)
}
@ -110,9 +110,9 @@ data Input
| Boolean Bool
| Null
| Enum Name
| List [Definition.Value]
| List [Type.Value]
| Object (HashMap Name Input)
| Variable Definition.Value
| Variable Type.Value
deriving (Eq, Show)
queryError :: QueryError -> Text
@ -168,12 +168,12 @@ lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
= In.NonNullListType
<$> lookupInputType nonNull types
coerceVariableValues :: VariableValue a
coerceVariableValues :: Coerce.VariableValue a
=> forall m
. HashMap Full.Name (Type m)
-> OperationDefinition
-> HashMap.HashMap Full.Name a
-> Either QueryError Definition.Subs
-> Either QueryError Type.Subs
coerceVariableValues types operationDefinition variableValues =
let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
in maybe (Left CoercionError) Right
@ -185,27 +185,33 @@ coerceVariableValues types operationDefinition variableValues =
let defaultValue' = constValue <$> defaultValue
variableType <- lookupInputType variableTypeName types
matchFieldValues coerceVariableValue' variableValues variableName variableType defaultValue' coercedValues
Coerce.matchFieldValues
coerceVariableValue'
variableValues
variableName
variableType
defaultValue'
coercedValues
coerceVariableValue' variableType value'
= coerceVariableValue variableType value'
>>= coerceInputLiteral variableType
= Coerce.coerceVariableValue variableType value'
>>= Coerce.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.ConstValue -> Type.Value
constValue (Full.ConstInt i) = Type.Int i
constValue (Full.ConstFloat f) = Type.Float f
constValue (Full.ConstString x) = Type.String x
constValue (Full.ConstBoolean b) = Type.Boolean b
constValue Full.ConstNull = Type.Null
constValue (Full.ConstEnum e) = Type.Enum e
constValue (Full.ConstList l) = Type.List $ constValue <$> l
constValue (Full.ConstObject o) =
Definition.Object $ HashMap.fromList $ constObjectField <$> o
Type.Object $ HashMap.fromList $ constObjectField <$> o
where
constObjectField (Full.ObjectField key value') = (key, constValue value')
-- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution.
document :: VariableValue a
document :: Coerce.VariableValue a
=> forall m
. Schema m
-> Maybe Full.Name
@ -386,30 +392,30 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
let newFragments = HashMap.insert name newValue fragments
in replacement{ fragments = newFragments }
value :: forall m. Full.Value -> State (Replacement m) Definition.Value
value :: forall m. Full.Value -> State (Replacement m) Type.Value
value (Full.Variable name) =
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) =
Definition.Object . HashMap.fromList <$> traverse objectField o
gets (fromMaybe Type.Null . HashMap.lookup name . variableValues)
value (Full.Int int) = pure $ Type.Int int
value (Full.Float float) = pure $ Type.Float float
value (Full.String string) = pure $ Type.String string
value (Full.Boolean boolean) = pure $ Type.Boolean boolean
value Full.Null = pure Type.Null
value (Full.Enum enum) = pure $ Type.Enum enum
value (Full.List list) = Type.List <$> traverse value list
value (Full.Object object) =
Type.Object . HashMap.fromList <$> traverse objectField object
where
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.Int int) = pure $ pure $ Int int
input (Full.Float float) = pure $ pure $ Float float
input (Full.String string) = pure $ pure $ String string
input (Full.Boolean boolean) = pure $ pure $ Boolean boolean
input Full.Null = pure $ pure Null
input (Full.Enum e) = pure $ pure $ Enum e
input (Full.Enum enum) = pure $ pure $ Enum enum
input (Full.List list) = pure . List <$> traverse value list
input (Full.Object object) = do
objectFields <- foldM objectField HashMap.empty object

View File

@ -9,7 +9,7 @@ import qualified Data.Aeson.Types as Aeson
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (isNothing)
import Data.Scientific (scientific)
import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Execute.Coerce as Coerce
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In
import Prelude hiding (id)
@ -30,55 +30,58 @@ singletonInputObject = In.NamedInputObjectType type'
inputFields = HashMap.singleton "field" field
field = In.InputField Nothing (In.NamedScalarType string) Nothing
namedIdType :: In.Type
namedIdType = In.NamedScalarType id
spec :: Spec
spec = do
describe "VariableValue Aeson" $ do
it "coerces strings" $
let expected = Just (String "asdf")
actual = coerceVariableValue
actual = Coerce.coerceVariableValue
(In.NamedScalarType string) (Aeson.String "asdf")
in actual `shouldBe` expected
it "coerces non-null strings" $
let expected = Just (String "asdf")
actual = coerceVariableValue
actual = Coerce.coerceVariableValue
(In.NonNullScalarType string) (Aeson.String "asdf")
in actual `shouldBe` expected
it "coerces booleans" $
let expected = Just (Boolean True)
actual = coerceVariableValue
actual = Coerce.coerceVariableValue
(In.NamedScalarType boolean) (Aeson.Bool True)
in actual `shouldBe` expected
it "coerces zero to an integer" $
let expected = Just (Int 0)
actual = coerceVariableValue
actual = Coerce.coerceVariableValue
(In.NamedScalarType int) (Aeson.Number 0)
in actual `shouldBe` expected
it "rejects fractional if an integer is expected" $
let actual = coerceVariableValue
let actual = Coerce.coerceVariableValue
(In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1))
in actual `shouldSatisfy` isNothing
it "coerces float numbers" $
let expected = Just (Float 1.4)
actual = coerceVariableValue
actual = Coerce.coerceVariableValue
(In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1))
in actual `shouldBe` expected
it "coerces IDs" $
let expected = Just (String "1234")
actual = coerceVariableValue
(In.NamedScalarType id) (Aeson.String "1234")
json = Aeson.String "1234"
actual = Coerce.coerceVariableValue namedIdType json
in actual `shouldBe` expected
it "coerces input objects" $
let actual = coerceVariableValue singletonInputObject
let actual = Coerce.coerceVariableValue singletonInputObject
$ Aeson.object ["field" .= ("asdf" :: Aeson.Value)]
expected = Just $ Object $ HashMap.singleton "field" "asdf"
in actual `shouldBe` expected
it "skips the field if it is missing in the variables" $
let actual = coerceVariableValue
let actual = Coerce.coerceVariableValue
singletonInputObject Aeson.emptyObject
expected = Just $ Object HashMap.empty
in actual `shouldBe` expected
it "fails if input object value contains extra fields" $
let actual = coerceVariableValue singletonInputObject
let actual = Coerce.coerceVariableValue singletonInputObject
$ Aeson.object variableFields
variableFields =
[ "field" .= ("asdf" :: Aeson.Value)
@ -86,26 +89,26 @@ spec = do
]
in actual `shouldSatisfy` isNothing
it "preserves null" $
let actual = coerceVariableValue (In.NamedScalarType id) Aeson.Null
let actual = Coerce.coerceVariableValue namedIdType Aeson.Null
in actual `shouldBe` Just Null
it "preserves list order" $
let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
listType = (In.ListType $ In.NamedScalarType string)
actual = coerceVariableValue listType list
actual = Coerce.coerceVariableValue listType list
expected = Just $ List [String "asdf", String "qwer"]
in actual `shouldBe` expected
describe "coerceInputLiterals" $ do
it "coerces enums" $
let expected = Just (Enum "NORTH")
actual = coerceInputLiteral
actual = Coerce.coerceInputLiteral
(In.NamedEnumType direction) (Enum "NORTH")
in actual `shouldBe` expected
it "fails with non-existing enum value" $
let actual = coerceInputLiteral
let actual = Coerce.coerceInputLiteral
(In.NamedEnumType direction) (Enum "NORTH_EAST")
in actual `shouldSatisfy` isNothing
it "coerces integers to IDs" $
let expected = Just (String "1234")
actual = coerceInputLiteral (In.NamedScalarType id) (Int 1234)
actual = Coerce.coerceInputLiteral namedIdType (Int 1234)
in actual `shouldBe` expected

View File

@ -12,7 +12,7 @@ import Language.GraphQL.AST (Name)
import Language.GraphQL.AST.Parser (document)
import Language.GraphQL.Error
import Language.GraphQL.Execute
import Language.GraphQL.Type
import Language.GraphQL.Type as Type
import Language.GraphQL.Type.Out as Out
import Test.Hspec (Spec, describe, it, shouldBe)
import Text.Megaparsec (parse)
@ -25,7 +25,7 @@ queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "philosopher"
$ Out.Resolver philosopherField
$ pure
$ Object mempty
$ Type.Object mempty
where
philosopherField =
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
@ -38,8 +38,8 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
[ ("firstName", firstNameResolver)
, ("lastName", lastNameResolver)
]
firstNameResolver = Out.Resolver firstNameField $ pure $ String "Friedrich"
lastNameResolver = Out.Resolver lastNameField $ pure $ String "Nietzsche"
firstNameResolver = Out.Resolver firstNameField $ pure $ Type.String "Friedrich"
lastNameResolver = Out.Resolver lastNameField $ pure $ Type.String "Nietzsche"
firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty

View File

@ -184,7 +184,7 @@ getFriends :: Character -> [Character]
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
getEpisode :: Int -> Maybe Text
getEpisode 4 = pure "NEWHOPE"
getEpisode 4 = pure "NEW_HOPE"
getEpisode 5 = pure "EMPIRE"
getEpisode 6 = pure "JEDI"
getEpisode _ = empty

View File

@ -77,7 +77,7 @@ spec = describe "Star Wars Query Tests" $ do
, "friends" .= [
Aeson.object [
"name" .= ("Luke Skywalker" :: Text)
, "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
, "friends" .= [
Aeson.object [hanName]
, Aeson.object [leiaName]
@ -87,7 +87,7 @@ spec = describe "Star Wars Query Tests" $ do
]
, Aeson.object [
hanName
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
, "friends" .=
[ Aeson.object [lukeName]
, Aeson.object [leiaName]
@ -96,7 +96,7 @@ spec = describe "Star Wars Query Tests" $ do
]
, Aeson.object [
leiaName
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
, "friends" .=
[ Aeson.object [lukeName]
, Aeson.object [hanName]

View File

@ -42,7 +42,7 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
[ ("id", Out.Resolver idFieldType (idField "id"))
, ("name", Out.Resolver nameFieldType (idField "name"))
, ("friends", Out.Resolver friendsFieldType (idField "friends"))
, ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn"))
, ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
, ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))
, ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
, ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
@ -55,7 +55,7 @@ droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
[ ("id", Out.Resolver idFieldType (idField "id"))
, ("name", Out.Resolver nameFieldType (idField "name"))
, ("friends", Out.Resolver friendsFieldType (idField "friends"))
, ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn"))
, ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
, ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))
, ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
, ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
@ -72,8 +72,11 @@ nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
friendsFieldType :: Out.Field Identity
friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
appearsInFieldType :: Out.Field Identity
appearsInFieldType = Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty
appearsInField :: Out.Field Identity
appearsInField = Out.Field (Just description) fieldType mempty
where
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
description = "Which movies they appear in."
secretBackstoryFieldType :: Out.Field Identity
secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
@ -97,7 +100,7 @@ hero :: ActionT Identity Value
hero = do
episode <- argument "episode"
pure $ character $ case episode of
Enum "NEWHOPE" -> getHero 4
Enum "NEW_HOPE" -> getHero 4
Enum "EMPIRE" -> getHero 5
Enum "JEDI" -> getHero 6
_ -> artoo