From 663e4f35213ac486ffbb86a76877fcac7b58a1e8 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sat, 18 Jan 2025 16:33:13 +0100 Subject: [PATCH] Make the lexer and parser safe --- graphql.cabal | 4 ++-- src/Language/GraphQL/AST.hs | 1 + src/Language/GraphQL/AST/DirectiveLocation.hs | 1 + src/Language/GraphQL/AST/Document.hs | 1 + src/Language/GraphQL/AST/Encoder.hs | 1 + src/Language/GraphQL/AST/Lexer.hs | 2 ++ src/Language/GraphQL/AST/Parser.hs | 2 ++ src/Language/GraphQL/Execute.hs | 21 +++++++++---------- src/Language/GraphQL/Type/Definition.hs | 1 + src/Language/GraphQL/Type/In.hs | 1 + src/Language/GraphQL/Validate/Rules.hs | 10 --------- 11 files changed, 22 insertions(+), 23 deletions(-) diff --git a/graphql.cabal b/graphql.cabal index 7088230..c31c058 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -11,7 +11,7 @@ author: Danny Navarro , Matthías Páll Gissurarson , Sólrún Halla Einarsdóttir maintainer: belka@caraus.de -copyright: (c) 2019-2024 Eugen Wissner, +copyright: (c) 2019-2025 Eugen Wissner, (c) 2015-2017 J. Daniel Navarro license: MPL-2.0 AND BSD-3-Clause license-files: LICENSE, @@ -21,7 +21,7 @@ extra-source-files: CHANGELOG.md README.md tested-with: - GHC == 9.8.2 + GHC == 9.10.1 source-repository head type: git diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index 4cf9bfd..93fe686 100644 --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -- | Target AST for parser. diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs index 600f931..10da19b 100644 --- a/src/Language/GraphQL/AST/DirectiveLocation.hs +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -- | Various parts of a GraphQL document can be annotated with directives. diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 11317d8..4fcdd41 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -- | This module defines an abstract syntax tree for the @GraphQL@ language. It diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 603023b..c26b2e7 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -- | This module defines a minifier and a printer for the @GraphQL@ language. diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index 62cf4d2..123383b 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} -- | This module defines a bunch of small parsers used to parse individual -- lexemes. diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index d3a6b34..8b03bb2 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -2,6 +2,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} -- | @GraphQL@ document parser. module Language.GraphQL.AST.Parser diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 265e94f..f959f64 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -189,6 +189,8 @@ data QueryError | CoercionError Full.VariableDefinition | UnknownInputType Full.VariableDefinition +type ExecuteHandler m a e = e -> ExecutorT m a + tell :: Monad m => Seq Error -> ExecutorT m () tell = ExecutorT . lift . Writer.tell @@ -313,8 +315,7 @@ executeQuery topSelections schema = do pure $ Response data' errors handleException :: (MonadCatch m, Serialize a) - => FieldException - -> ExecutorT m a + => ExecuteHandler m a FieldException handleException (FieldException fieldLocation errorPath next) = let newError = constructError next fieldLocation errorPath in tell (Seq.singleton newError) >> pure null @@ -390,30 +391,28 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath = fieldErrorPath = fieldsSegment fields : errorPath inputCoercionHandler :: (MonadCatch m, Serialize a) => Full.Location - -> InputCoercionException - -> ExecutorT m a + -> ExecuteHandler m a InputCoercionException inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) = let argumentLocation = getField @"location" valueNode in exceptionHandler argumentLocation e inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e resultHandler :: (MonadCatch m, Serialize a) => Full.Location - -> ResultException - -> ExecutorT m a + -> ExecuteHandler m a ResultException resultHandler = exceptionHandler resolverHandler :: (MonadCatch m, Serialize a) => Full.Location - -> ResolverException - -> ExecutorT m a + -> ExecuteHandler m a ResolverException resolverHandler = exceptionHandler - nullResultHandler :: (MonadCatch m, Serialize a) - => FieldException - -> ExecutorT m a + nullResultHandler :: (MonadCatch m, Serialize a) => ExecuteHandler m a FieldException nullResultHandler e@(FieldException fieldLocation errorPath' next) = let newError = constructError next fieldLocation errorPath' in if Out.isNonNullType fieldType then throwM e else returnError newError + exceptionHandler :: (Exception e, MonadCatch m, Serialize a) + => Full.Location + -> ExecuteHandler m a e exceptionHandler errorLocation e = let newError = constructError e errorLocation fieldErrorPath in if Out.isNonNullType fieldType diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index ad4b538..e3616d1 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -- | Types that can be used as both input and output types. diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs index bd78c8c..1fdedf4 100644 --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.hs @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-} diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 1c202fe..9d3561f 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -1067,18 +1067,12 @@ overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case go selectionSet selectionType = do fieldTuples <- evalStateT (collectFields selectionType selectionSet) HashSet.empty fieldsInSetCanMerge fieldTuples - fieldsInSetCanMerge :: forall m - . HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m)) - -> ReaderT (Validation m) Seq Error fieldsInSetCanMerge fieldTuples = do validation <- ask let (lonely, paired) = flattenPairs fieldTuples let reader = flip runReaderT validation lift $ foldMap (reader . visitLonelyFields) lonely <> foldMap (reader . forEachFieldTuple) paired - forEachFieldTuple :: forall m - . (FieldInfo m, FieldInfo m) - -> ReaderT (Validation m) Seq Error forEachFieldTuple (fieldA, fieldB) = case (parent fieldA, parent fieldB) of (parentA@Type.CompositeObjectType{}, parentB@Type.CompositeObjectType{}) @@ -1105,10 +1099,6 @@ overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case let Full.Field _ _ _ _ subSelections _ = node compositeFieldType = Type.outToComposite type' in maybe (lift Seq.empty) (go subSelections) compositeFieldType - sameResponseShape :: forall m - . FieldInfo m - -> FieldInfo m - -> ReaderT (Validation m) Seq Error sameResponseShape fieldA fieldB = let Full.Field _ _ _ _ selectionsA _ = node fieldA Full.Field _ _ _ _ selectionsB _ = node fieldB