From 882276a845c33c06b235d9604cbfd5b55d784c7d Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sat, 13 Jun 2020 07:20:19 +0200 Subject: [PATCH] Coerce result Fixes #45. --- docs/tutorial/tutorial.lhs | 6 +- src/Language/GraphQL/Execute.hs | 4 +- src/Language/GraphQL/Execute/Coerce.hs | 142 +++++++++++----- src/Language/GraphQL/Execute/Execution.hs | 160 +++++++++++-------- src/Language/GraphQL/Execute/Transform.hs | 78 ++++----- tests/Language/GraphQL/Execute/CoerceSpec.hs | 37 +++-- tests/Language/GraphQL/ExecuteSpec.hs | 8 +- tests/Test/StarWars/Data.hs | 2 +- tests/Test/StarWars/QuerySpec.hs | 12 +- tests/Test/StarWars/Schema.hs | 13 +- 10 files changed, 278 insertions(+), 184 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 + = 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 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