OSS/graphql
1
1
Fork 1
Code Issues 5 Pull Requests Actions Releases 22 Wiki Activity

Coerce result

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
docs/tutorial/tutorial.lhs
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. To run the query, we call the `graphql` with the schema and the query.
> main1 :: IO () > main1 :: IO ()
> main1 = putStrLn =<< encode <$> graphql schema1 query1 > main1 = graphql schema1 query1 >>= putStrLn . encode
This runs the query by fetching the one field defined, This runs the query by fetching the one field defined,
returning returning
@ -99,7 +99,7 @@ Next we define our query.
> query2 = "{ time }" > query2 = "{ time }"
> >
> main2 :: IO () > main2 :: IO ()
> main2 = putStrLn =<< encode <$> graphql schema2 query2 > main2 = graphql schema2 query2 >>= putStrLn . encode
This runs the query, returning the current time 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 }" > query3 = "query timeAndHello { time hello }"
> >
> main3 :: IO () > main3 :: IO ()
> main3 = putStrLn =<< encode <$> graphql schema3 query3 > main3 = graphql schema3 query3 >>= putStrLn . encode
This queries for both time and hello, returning This queries for both time and hello, returning

4
src/Language/GraphQL/Execute.hs
View File

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

142
src/Language/GraphQL/Execute/Coerce.hs
View File

@ -3,21 +3,28 @@
-- | Types and functions used for input and result coercion. -- | Types and functions used for input and result coercion.
module Language.GraphQL.Execute.Coerce module Language.GraphQL.Execute.Coerce
( VariableValue(..) ( Output(..)
, Serialize(..)
, VariableValue(..)
, coerceInputLiteral , coerceInputLiteral
, matchFieldValues , matchFieldValues
) where ) where
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as 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 as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy.Builder.Int as Text.Builder import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import Data.Scientific (toBoundedInteger, toRealFloat) import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST (Name) import Language.GraphQL.AST (Name)
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In 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 -- | Since variables are passed separately from the query, in an independent
-- format, they should be first coerced to the internal representation used by -- format, they should be first coerced to the internal representation used by
@ -46,26 +53,26 @@ class VariableValue a where
coerceVariableValue coerceVariableValue
:: In.Type -- ^ Expected type (variable type given in the query). :: In.Type -- ^ Expected type (variable type given in the query).
-> a -- ^ Variable value being coerced. -> 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 instance VariableValue Aeson.Value where
coerceVariableValue _ Aeson.Null = Just Null coerceVariableValue _ Aeson.Null = Just Type.Null
coerceVariableValue (In.ScalarBaseType scalarType) value coerceVariableValue (In.ScalarBaseType scalarType) value
| (Aeson.String stringValue) <- value = Just $ String stringValue | (Aeson.String stringValue) <- value = Just $ Type.String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
| (Aeson.Number numberValue) <- value | (Aeson.Number numberValue) <- value
, (ScalarType "Float" _) <- scalarType = , (Type.ScalarType "Float" _) <- scalarType =
Just $ Float $ toRealFloat numberValue Just $ Type.Float $ toRealFloat numberValue
| (Aeson.Number numberValue) <- value = -- ID or Int | (Aeson.Number numberValue) <- value = -- ID or Int
Int <$> toBoundedInteger numberValue Type.Int <$> toBoundedInteger numberValue
coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) = coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
Just $ Enum stringValue Just $ Type.Enum stringValue
coerceVariableValue (In.InputObjectBaseType objectType) value coerceVariableValue (In.InputObjectBaseType objectType) value
| (Aeson.Object objectValue) <- value = do | (Aeson.Object objectValue) <- value = do
let (In.InputObjectType _ _ inputFields) = objectType let (In.InputObjectType _ _ inputFields) = objectType
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if HashMap.null newObjectValue if HashMap.null newObjectValue
then Just $ Object resultMap then Just $ Type.Object resultMap
else Nothing else Nothing
where where
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues' foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
@ -81,8 +88,8 @@ instance VariableValue Aeson.Value where
pure (newObjectValue, insert coerced) pure (newObjectValue, insert coerced)
Nothing -> Just (objectValue, resultMap) Nothing -> Just (objectValue, resultMap)
coerceVariableValue (In.ListBaseType listType) value coerceVariableValue (In.ListBaseType listType) value
| (Aeson.Array arrayValue) <- value = List | (Aeson.Array arrayValue) <- value =
<$> foldr foldVector (Just []) arrayValue Type.List <$> foldr foldVector (Just []) arrayValue
| otherwise = coerceVariableValue listType value | otherwise = coerceVariableValue listType value
where where
foldVector _ Nothing = Nothing 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 -- result map. Otherwise it fails with 'Nothing' if the Input Type is a
-- Non-Nullable type, or returns the unchanged, original map. -- Non-Nullable type, or returns the unchanged, original map.
matchFieldValues :: forall a matchFieldValues :: forall a
. (In.Type -> a -> Maybe Value) . (In.Type -> a -> Maybe Type.Value)
-> HashMap Name a -> HashMap Name a
-> Name -> Name
-> In.Type -> In.Type
-> Maybe Value -> Maybe Type.Value
-> Maybe (HashMap Name Value) -> Maybe (HashMap Name Type.Value)
-> Maybe (HashMap Name Value) -> Maybe (HashMap Name Type.Value)
matchFieldValues coerce values' fieldName type' defaultValue resultMap = matchFieldValues coerce values' fieldName type' defaultValue resultMap =
case HashMap.lookup fieldName values' of case HashMap.lookup fieldName values' of
Just variableValue -> coerceRuntimeValue $ coerce type' variableValue Just variableValue -> coerceRuntimeValue $ coerce type' variableValue
@ -114,44 +121,99 @@ matchFieldValues coerce values' fieldName type' defaultValue resultMap =
, In.isNonNullType type' -> Nothing , In.isNonNullType type' -> Nothing
| otherwise -> resultMap | otherwise -> resultMap
where where
coerceRuntimeValue (Just Null) coerceRuntimeValue (Just Type.Null)
| In.isNonNullType type' = Nothing | In.isNonNullType type' = Nothing
coerceRuntimeValue coercedValue = coerceRuntimeValue coercedValue =
HashMap.insert fieldName <$> coercedValue <*> resultMap HashMap.insert fieldName <$> coercedValue <*> resultMap
-- | Coerces operation arguments according to the input coercion rules for the -- | Coerces operation arguments according to the input coercion rules for the
-- corresponding types. -- corresponding types.
coerceInputLiteral :: In.Type -> Value -> Maybe Value coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value
coerceInputLiteral (In.ScalarBaseType type') value coerceInputLiteral (In.ScalarBaseType type') value
| (String stringValue) <- value | (Type.String stringValue) <- value
, (ScalarType "String" _) <- type' = Just $ String stringValue , (Type.ScalarType "String" _) <- type' = Just $ Type.String stringValue
| (Boolean booleanValue) <- value | (Type.Boolean booleanValue) <- value
, (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue , (Type.ScalarType "Boolean" _) <- type' = Just $ Type.Boolean booleanValue
| (Int intValue) <- value | (Type.Int intValue) <- value
, (ScalarType "Int" _) <- type' = Just $ Int intValue , (Type.ScalarType "Int" _) <- type' = Just $ Type.Int intValue
| (Float floatValue) <- value | (Type.Float floatValue) <- value
, (ScalarType "Float" _) <- type' = Just $ Float floatValue , (Type.ScalarType "Float" _) <- type' = Just $ Type.Float floatValue
| (Int intValue) <- value | (Type.Int intValue) <- value
, (ScalarType "Float" _) <- type' = , (Type.ScalarType "Float" _) <- type' =
Just $ Float $ fromIntegral intValue Just $ Type.Float $ fromIntegral intValue
| (String stringValue) <- value | (Type.String stringValue) <- value
, (ScalarType "ID" _) <- type' = Just $ String stringValue , (Type.ScalarType "ID" _) <- type' = Just $ Type.String stringValue
| (Int intValue) <- value | (Type.Int intValue) <- value
, (ScalarType "ID" _) <- type' = Just $ decimal intValue , (Type.ScalarType "ID" _) <- type' = Just $ decimal intValue
where where
decimal = String decimal = Type.String
. Text.Lazy.toStrict . Text.Lazy.toStrict
. Text.Builder.toLazyText . Text.Builder.toLazyText
. Text.Builder.decimal . Text.Builder.decimal
coerceInputLiteral (In.EnumBaseType type') (Enum enumValue) coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)
| member enumValue type' = Just $ Enum enumValue | member enumValue type' = Just $ Type.Enum enumValue
where where
member value (EnumType _ _ members) = HashMap.member value members member value (Type.EnumType _ _ members) = HashMap.member value members
coerceInputLiteral (In.InputObjectBaseType type') (Object values) = coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) =
let (In.InputObjectType _ _ inputFields) = type' let (In.InputObjectType _ _ inputFields) = type'
in Object in Type.Object
<$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields
where where
matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) = matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) =
matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue
coerceInputLiteral _ _ = Nothing 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

160
src/Language/GraphQL/Execute/Execution.hs
View File

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

78
src/Language/GraphQL/Execute/Transform.hs
View File

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

37
tests/Language/GraphQL/Execute/CoerceSpec.hs
View File

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

8
tests/Language/GraphQL/ExecuteSpec.hs
View File

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

2
tests/Test/StarWars/Data.hs
View File

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

6
tests/Test/StarWars/QuerySpec.hs
View File

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

13
tests/Test/StarWars/Schema.hs
View File

@ -42,7 +42,7 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
[ ("id", Out.Resolver idFieldType (idField "id")) [ ("id", Out.Resolver idFieldType (idField "id"))
, ("name", Out.Resolver nameFieldType (idField "name")) , ("name", Out.Resolver nameFieldType (idField "name"))
, ("friends", Out.Resolver friendsFieldType (idField "friends")) , ("friends", Out.Resolver friendsFieldType (idField "friends"))
, ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn")) , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
, ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet")) , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))
, ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory)) , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
, ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename")) , ("__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")) [ ("id", Out.Resolver idFieldType (idField "id"))
, ("name", Out.Resolver nameFieldType (idField "name")) , ("name", Out.Resolver nameFieldType (idField "name"))
, ("friends", Out.Resolver friendsFieldType (idField "friends")) , ("friends", Out.Resolver friendsFieldType (idField "friends"))
, ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn")) , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
, ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction")) , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))
, ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory)) , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
, ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename")) , ("__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 Identity
friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
appearsInFieldType :: Out.Field Identity appearsInField :: Out.Field Identity
appearsInFieldType = Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty 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 Identity
secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
@ -97,7 +100,7 @@ hero :: ActionT Identity Value
hero = do hero = do
episode <- argument "episode" episode <- argument "episode"
pure $ character $ case episode of pure $ character $ case episode of
Enum "NEWHOPE" -> getHero 4 Enum "NEW_HOPE" -> getHero 4
Enum "EMPIRE" -> getHero 5 Enum "EMPIRE" -> getHero 5
Enum "JEDI" -> getHero 6 Enum "JEDI" -> getHero 6
_ -> artoo _ -> artoo