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

Don't fail on invalid fragments and variables

Browse Source
This commit is contained in:
Eugen Wissner
2020-05-23 06:46:21 +02:00
parent 26cc53ce06
commit 7cd4821718
17 changed files with 219 additions and 169 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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') =

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

@ -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

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

@ -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

58
src/Language/GraphQL/Schema.hs
View File

@ -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
wrappedObject name = Resolver name . Definition.NestingResolver
-- | 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
-- | 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

38
src/Language/GraphQL/Type.hs
View File

@ -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-}

12
src/Language/GraphQL/Type/Definition.hs
View File

@ -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)

2
src/Language/GraphQL/Type/Schema.hs
View File

@ -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