Don't fail on invalid fragments and variables

7 files changed, 121 insertions, 89 deletions

diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 7513b6e..295cb44 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -54,7 +54,7 @@ document :: (Monad m, VariableValue a)
 document schema operationName subs document' =
     case Transform.document schema operationName subs document' of
         Left queryError -> pure $ singleError $ Transform.queryError queryError
-        Right (Transform.Document op _) -> operation schema op
+        Right (Transform.Document operation') -> operation schema operation'
 
 operation :: Monad m
     => Schema m
@@ -65,7 +65,8 @@ operation = schemaOperation
     resolve queryFields = runCollectErrs
         . flip Schema.resolve queryFields
         . fmap getResolver
-        . Definition.fields
+        . fields
+    fields (Definition.ObjectType _ _ objectFields) = objectFields
     lookupError = pure
         $ singleError "Root operation type couldn't be found in the schema."
     schemaOperation Schema {query} (AST.Core.Query _ fields') =
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
index ead19dc..6997945 100644
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@@ -4,6 +4,7 @@
 module Language.GraphQL.Execute.Coerce
     ( VariableValue(..)
     , coerceInputLiterals
+    , isNonNullInputType
     ) where
 
 import qualified Data.Aeson as Aeson
@@ -148,6 +149,7 @@ coerceInputLiterals variableTypes variableValues =
         . Text.Builder.toLazyText
         . Text.Builder.decimal
 
+-- | Checks whether the given input type is a non-null type.
 isNonNullInputType :: InputType -> Bool
 isNonNullInputType (NonNullScalarInputType _) = True
 isNonNullInputType (NonNullEnumInputType _) = True
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 485bd51..df64254 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -15,11 +15,12 @@ module Language.GraphQL.Execute.Transform
 
 import Control.Monad (foldM, unless)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
-import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
+import Control.Monad.Trans.State (State, evalStateT, gets, modify)
 import Data.Foldable (find)
+import Data.Functor.Identity (Identity(..))
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe (fromMaybe)
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq, (<|), (><))
@@ -37,17 +38,13 @@ import Language.GraphQL.Type.Schema
 data Replacement = Replacement
     { fragments :: HashMap Core.Name Core.Fragment
     , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+    , variableValues :: Schema.Subs
     }
 
-type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
-
-liftJust :: forall a. a -> TransformT a
-liftJust = lift . lift . Just
+type TransformT a = State Replacement a
 
 -- | GraphQL document is a non-empty list of operations.
-data Document = Document
-    Core.Operation
-    (HashMap Full.Name Full.FragmentDefinition)
+newtype Document = Document Core.Operation
 
 data OperationDefinition = OperationDefinition
     Full.OperationType
@@ -120,18 +117,44 @@ coerceVariableValues :: (Monad m, VariableValue a)
     -> OperationDefinition
     -> HashMap.HashMap Full.Name a
     -> Either QueryError Schema.Subs
-coerceVariableValues schema (OperationDefinition _ _ variables _ _) values =
+coerceVariableValues schema operationDefinition variableValues' =
     let referencedTypes = collectReferencedTypes schema
+        OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
+        coerceValue' = coerceValue referencedTypes
      in maybe (Left CoercionError) Right
-        $ foldr (coerceValue referencedTypes) (Just HashMap.empty) variables
+        $ foldr coerceValue' (Just HashMap.empty) variableDefinitions
   where
     coerceValue referencedTypes variableDefinition coercedValues = do
-        let Full.VariableDefinition variableName variableTypeName _defaultValue =
+        let Full.VariableDefinition variableName variableTypeName defaultValue =
                 variableDefinition
+        let defaultValue' = constValue <$> defaultValue
+        let value' = HashMap.lookup variableName variableValues'
+
         variableType <- lookupInputType variableTypeName referencedTypes
-        value' <- HashMap.lookup variableName values
-        coercedValue <- coerceVariableValue variableType value'
-        HashMap.insert variableName coercedValue <$> coercedValues
+        HashMap.insert variableName
+            <$> choose value' defaultValue' variableType
+            <*> coercedValues
+    choose Nothing defaultValue variableType
+        | Just _ <- defaultValue = defaultValue
+        | not (isNonNullInputType variableType) = Just Core.Null
+    choose (Just value') _ variableType
+        | Just coercedValue <- coerceVariableValue variableType value'
+        , not (isNonNullInputType variableType) || coercedValue /= Core.Null =
+            Just coercedValue
+    choose _ _ _ = Nothing
+
+constValue :: Full.ConstValue -> Core.Value
+constValue (Full.ConstInt i) = Core.Int i
+constValue (Full.ConstFloat f) = Core.Float f
+constValue (Full.ConstString x) = Core.String x
+constValue (Full.ConstBoolean b) = Core.Boolean b
+constValue Full.ConstNull = Core.Null
+constValue (Full.ConstEnum e) = Core.Enum e
+constValue (Full.ConstList l) = Core.List $ constValue <$> l
+constValue (Full.ConstObject o) =
+    Core.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.
@@ -148,10 +171,8 @@ document schema operationName subs ast = do
     chosenOperation <- getOperation operationName nonEmptyOperations
     coercedValues <- coerceVariableValues schema chosenOperation subs
 
-    maybe (Left TransformationError) Right
-        $ Document
-        <$> operation fragmentTable coercedValues chosenOperation
-        <*> pure fragmentTable
+    pure $ Document
+        $ operation fragmentTable coercedValues chosenOperation
   where
     defragment definition (operations, fragments')
         | (Full.ExecutableDefinition executable) <- definition
@@ -174,10 +195,11 @@ operation
     :: HashMap Full.Name Full.FragmentDefinition
     -> Schema.Subs
     -> OperationDefinition
-    -> Maybe Core.Operation
-operation fragmentTable subs operationDefinition = flip runReaderT subs
+    -> Core.Operation
+operation fragmentTable subs operationDefinition
+    = runIdentity
     $ evalStateT (collectFragments >> transform operationDefinition)
-    $ Replacement HashMap.empty fragmentTable
+    $ Replacement HashMap.empty fragmentTable subs
   where
     transform :: OperationDefinition -> TransformT Core.Operation
     transform (OperationDefinition Full.Query name _ _ sels) =
@@ -201,13 +223,15 @@ selection (Full.FragmentSpread name directives') =
     maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
         spreadDirectives <- Directive.selection <$> directives directives'
         fragments' <- gets fragments
-        fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
-        pure $ fragment <$ spreadDirectives
-  where
-    lookupDefinition = do
+
         fragmentDefinitions' <- gets fragmentDefinitions
-        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
-        fragmentDefinition found
+        case HashMap.lookup name fragments' of
+            Just definition -> lift $ pure $ definition <$ spreadDirectives
+            Nothing -> case HashMap.lookup name fragmentDefinitions' of
+                         Just definition -> do
+                             fragment <- fragmentDefinition definition
+                             lift $ pure $ fragment <$ spreadDirectives
+                         Nothing -> lift $ pure  Nothing
 selection (Full.InlineFragment type' directives' selections) = do
     fragmentDirectives <- Directive.selection <$> directives directives'
     case fragmentDirectives of
@@ -255,13 +279,13 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
     fragmentSelection <- appendSelection selections
     let newValue = Core.Fragment type' fragmentSelection
     modify $ insertFragment newValue
-    liftJust newValue
+    lift $ pure newValue
   where
-    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =
-        Replacement fragments' $ HashMap.delete name fragmentDefinitions'
-    insertFragment newValue (Replacement fragments' fragmentDefinitions') =
+    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions' subs) =
+        Replacement fragments' (HashMap.delete name fragmentDefinitions') subs
+    insertFragment newValue (Replacement fragments' fragmentDefinitions' subs) =
         let newFragments = HashMap.insert name newValue fragments'
-         in Replacement newFragments fragmentDefinitions'
+         in Replacement newFragments fragmentDefinitions' subs
 
 arguments :: [Full.Argument] -> TransformT Core.Arguments
 arguments = fmap Core.Arguments . foldM go HashMap.empty
@@ -271,7 +295,8 @@ arguments = fmap Core.Arguments . foldM go HashMap.empty
         return $ HashMap.insert name substitutedValue arguments'
 
 value :: Full.Value -> TransformT Core.Value
-value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
+value (Full.Variable name) =
+    gets $ fromMaybe Core.Null . HashMap.lookup name . variableValues
 value (Full.Int i) = pure $ Core.Int i
 value (Full.Float f) = pure $ Core.Float f
 value (Full.String x) = pure $ Core.String x
diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index 752ce29..69f697e 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/src/Language/GraphQL/Schema.hs
@@ -8,9 +8,7 @@ module Language.GraphQL.Schema
     , object
     , resolve
     , resolversToMap
-    , scalar
     , wrappedObject
-    , wrappedScalar
     -- * AST Reexports
     , Field
     , Value(..)
@@ -50,31 +48,18 @@ resolversToMap = HashMap.fromList . toList . fmap toKV
 --   and the value is the variable value.
 type Subs = HashMap Name Value
 
--- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
-object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
-object name = Resolver name
-    . Definition.NestingResolver
-    . fmap (Type.Named . resolversToMap)
-
 -- | Like 'object' but can be null or a list of objects.
 wrappedObject :: Monad m
     => Name
-    -> ActionT m (Type.Wrapping [Resolver m])
+    -> ActionT m (Type.Wrapping (Definition.FieldResolver m))
     -> Resolver m
-wrappedObject name = Resolver name
-    . Definition.NestingResolver
-    . (fmap . fmap) resolversToMap
-
--- | A scalar represents a primitive value, like a string or an integer.
-scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
-scalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
+wrappedObject name = Resolver name . Definition.NestingResolver
 
--- | Like 'scalar' but can be null or a list of scalars.
-wrappedScalar :: (Monad m, Aeson.ToJSON a)
-    => Name
-    -> ActionT m (Type.Wrapping a)
-    -> Resolver m
-wrappedScalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
+-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
+object :: Monad m
+    => [Resolver m]
+    -> Type.Wrapping (Definition.FieldResolver m)
+object = Type.O . resolversToMap
 
 resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
 resolveFieldValue field@(Field _ _ args _) =
@@ -82,11 +67,6 @@ resolveFieldValue field@(Field _ _ args _) =
     . runExceptT
     . runActionT
 
-convert :: Type.Wrapping Aeson.Value -> Aeson.Value
-convert Type.Null = Aeson.Null
-convert (Type.Named value) = value
-convert (Type.List value) = Aeson.toJSON value
-
 withField :: Monad m
     => Field
     -> Definition.FieldResolver m
@@ -94,14 +74,22 @@ withField :: Monad m
 withField field (Definition.ValueResolver resolver) = do
     answer <- lift $ resolveFieldValue field resolver
     either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
-withField field@(Field _ _ _ seqSelection) (Definition.NestingResolver resolver) = do
+withField field (Definition.NestingResolver resolver) = do
     answer <- lift $ resolveFieldValue field resolver
     case answer of
-        Right result -> do
-            nestedFields <- traverse (`resolve` seqSelection) result
-            pure $ HashMap.singleton (aliasOrName field) $ convert nestedFields
+        Right result -> HashMap.singleton (aliasOrName field) <$> toJSON field result
         Left errorMessage -> errmsg field errorMessage
 
+toJSON :: Monad m => Field -> Type.Wrapping (Definition.FieldResolver m) -> CollectErrsT m Aeson.Value
+toJSON _ Type.Null = pure Aeson.Null
+toJSON _ (Type.I i) = pure $ Aeson.toJSON i
+toJSON _ (Type.B i) = pure $ Aeson.toJSON i
+toJSON _ (Type.F i) = pure $ Aeson.toJSON i
+toJSON _ (Type.E i) = pure $ Aeson.toJSON i
+toJSON _ (Type.S i) = pure $ Aeson.toJSON i
+toJSON field (Type.List list) = Aeson.toJSON <$> traverse (toJSON field) list
+toJSON (Field _ _ _ seqSelection) (Type.O map') = map' `resolve` seqSelection
+
 errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value)
 errmsg field errorMessage = do
     addErrMsg errorMessage
@@ -127,6 +115,14 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
             if Right (Aeson.String typeCondition) == that
                 then fmap fold . traverse tryResolvers $ selections'
                 else pure mempty
+        | Just (Definition.NestingResolver resolver) <- lookupResolver "__typename" = do
+            let fakeField = Field Nothing "__typename" mempty mempty
+            that <- lift $ resolveFieldValue fakeField resolver
+            case that of
+                Right (Type.S typeCondition')
+                    | typeCondition' == typeCondition ->
+                        fmap fold . traverse tryResolvers $ selections'
+                _ -> pure mempty
         | otherwise = fmap fold . traverse tryResolvers $ selections'
 
 aliasOrName :: Field -> Text
diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs
index c8a9997..12b38dc 100644
--- a/src/Language/GraphQL/Type.hs
+++ b/src/Language/GraphQL/Type.hs
@@ -3,8 +3,9 @@ module Language.GraphQL.Type
     ( Wrapping(..)
     ) where
 
-import Data.Aeson as Aeson (ToJSON, toJSON)
-import qualified Data.Aeson as Aeson
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
+import Language.GraphQL.AST.Document (Name)
 
 -- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
 --   type can wrap other wrapping or named types. Wrapping types are lists and
@@ -15,26 +16,38 @@ import qualified Data.Aeson as Aeson
 --   nullable or an (arbitrary nested) list.
 data Wrapping a
     = List [Wrapping a] -- ^ Arbitrary nested list
-    | Named a -- ^ Named type without further wrapping
+--    | Named a -- ^ Named type without further wrapping
     | Null -- ^ Null
+    | O (HashMap Name a)
+    | I Int
+    | B Bool
+    | F Float
+    | E Text
+    | S Text
     deriving (Eq, Show)
 
 instance Functor Wrapping where
     fmap f (List list) = List $ fmap (fmap f) list
-    fmap f (Named named) = Named $ f named
+    fmap f (O map') = O $ f <$> map'
     fmap _ Null = Null
+    fmap _ (I i) = I i
+    fmap _ (B i) = B i
+    fmap _ (F i) = F i
+    fmap _ (E i) = E i
+    fmap _ (S i) = S i
 
-instance Foldable Wrapping where
+    {-instance Foldable Wrapping where
     foldr f acc (List list) = foldr (flip $ foldr f) acc list
-    foldr f acc (Named named) = f named acc
-    foldr _ acc Null = acc
+    foldr f acc (O map') = foldr f acc map'
+    foldr _ acc _ = acc -}
 
-instance Traversable Wrapping where
+    {-instance Traversable Wrapping where
     traverse f (List list) = List <$> traverse (traverse f) list
     traverse f (Named named) = Named <$> f named
     traverse _ Null = pure Null
+    traverse f (O map') = O <$> traverse f map'-}
 
-instance Applicative Wrapping where
+{-instance Applicative Wrapping where
     pure = Named
     Null <*> _ = Null
     _ <*> Null = Null
@@ -47,9 +60,4 @@ instance Monad Wrapping where
     return = pure
     Null >>= _ = Null
     (Named x) >>= f = f x
-    (List xs) >>= f = List $ fmap (>>= f) xs
-
-instance ToJSON a => ToJSON (Wrapping a) where
-    toJSON (List list) = toJSON list
-    toJSON (Named named) = toJSON named
-    toJSON Null = Aeson.Null
+    (List xs) >>= f = List $ fmap (>>= f) xs-}
diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs
index a916d51..559611b 100644
--- a/src/Language/GraphQL/Type/Definition.hs
+++ b/src/Language/GraphQL/Type/Definition.hs
@@ -44,21 +44,21 @@ import Prelude hiding (id)
 --
 --   Almost all of the GraphQL types you define will be object types. Object
 --   types have a name, but most importantly describe their fields.
-data ObjectType m = ObjectType
-    { name :: Text
-    , fields :: HashMap Name (Field m)
-    }
+data ObjectType m = ObjectType Name (Maybe Text) (HashMap Name (Field m))
 
 -- | Output object field definition.
 data Field m = Field
-    (Maybe Text) (OutputType m) (HashMap Name Argument) (FieldResolver m)
+    (Maybe Text) -- ^ Description.
+    (OutputType m) -- ^ Field type.
+    (HashMap Name Argument) -- ^ Arguments.
+    (FieldResolver m) -- ^ Resolver.
 
 -- | Resolving a field can result in a leaf value or an object, which is
 -- represented as a list of nested resolvers, used to resolve the fields of that
 -- object.
 data FieldResolver m
     = ValueResolver (ActionT m Aeson.Value)
-    | NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
+    | NestingResolver (ActionT m (Type.Wrapping (FieldResolver m)))
 
 -- | Field argument definition.
 data Argument = Argument (Maybe Text) InputType (Maybe Value)
diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs
index fa44694..095f27d 100644
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@@ -62,7 +62,7 @@ collectReferencedTypes schema =
         let (EnumType typeName _ _) = enumType
          in collect Prelude.id typeName (EnumTypeDefinition enumType)
     traverseObjectType objectType foundTypes =
-        let (ObjectType typeName objectFields) = objectType
+        let (ObjectType typeName _ objectFields) = objectType
             element = ObjectTypeDefinition objectType
             traverser = flip (foldr visitFields) objectFields
          in collect traverser typeName element foundTypes