summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEugen Wissner <belka@caraus.de>2020-06-13 07:20:19 +0200
committerEugen Wissner <belka@caraus.de>2020-06-13 07:20:19 +0200
commit882276a845c33c06b235d9604cbfd5b55d784c7d (patch)
treef6a4e9af38ae6772fa2ae49bb22e565996d1d06e
parente8c54810f8978b29e136ac0e1d91db8545a3f5f5 (diff)
downloadgraphql-882276a845c33c06b235d9604cbfd5b55d784c7d.tar.gz
Coerce result
Fixes #45.
-rw-r--r--docs/tutorial/tutorial.lhs6
-rw-r--r--src/Language/GraphQL/Execute.hs4
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs142
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs160
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs80
-rw-r--r--tests/Language/GraphQL/Execute/CoerceSpec.hs37
-rw-r--r--tests/Language/GraphQL/ExecuteSpec.hs8
-rw-r--r--tests/Test/StarWars/Data.hs2
-rw-r--r--tests/Test/StarWars/QuerySpec.hs12
-rw-r--r--tests/Test/StarWars/Schema.hs13
10 files changed, 279 insertions, 185 deletions
diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs
index 9a2242e..13afb81 100644
--- a/docs/tutorial/tutorial.lhs
+++ b/docs/tutorial/tutorial.lhs
@@ -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
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index cfa935c..45bace0 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -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
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
index b550bea..88ab412 100644
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@@ -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
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 647c60f..0c10419 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -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
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 315136c..733ac8c 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -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
-
-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
+ = Coerce.coerceVariableValue variableType value'
+ >>= Coerce.coerceInputLiteral variableType
+
+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
diff --git a/tests/Language/GraphQL/Execute/CoerceSpec.hs b/tests/Language/GraphQL/Execute/CoerceSpec.hs
index d800230..e39d550 100644
--- a/tests/Language/GraphQL/Execute/CoerceSpec.hs
+++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs
@@ -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
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 62c6f25..30568be 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -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
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
index bfbe836..427371b 100644
--- a/tests/Test/StarWars/Data.hs
+++ b/tests/Test/StarWars/Data.hs
@@ -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
diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs
index 39d6a27..cf451f8 100644
--- a/tests/Test/StarWars/QuerySpec.hs
+++ b/tests/Test/StarWars/QuerySpec.hs
@@ -64,9 +64,9 @@ spec = describe "Star Wars Query Tests" $ do
friends {
name
appearsIn
- friends {
- name
- }
+ friends {
+ name
+ }
}
}
}
@@ -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]
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 6296461..c9f1bed 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -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