Make the lexer and parser safe

graphql.cabal

@@ -11,7 +11,7 @@ author:         Danny Navarro <j@dannynavarro.net>,
                 Matthías Páll Gissurarson <mpg@mpg.is>,
                 Sólrún Halla Einarsdóttir <she@mpg.is>
 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

src/Language/GraphQL/AST.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
 {-# LANGUAGE Safe #-}
 
 -- | Target AST for parser.

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.

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

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.

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.

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

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
+    => ExecuteHandler m a FieldException
-    -> ExecutorT m a
 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
+        -> ExecuteHandler m a InputCoercionException
-        -> ExecutorT m a
     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
+        -> ExecuteHandler m a ResultException
-        -> ExecutorT m a
     resultHandler = exceptionHandler
     resolverHandler :: (MonadCatch m, Serialize a)
         => Full.Location
-        -> ResolverException
+        -> ExecuteHandler m a ResolverException
-        -> ExecutorT m a
     resolverHandler = exceptionHandler
-    nullResultHandler :: (MonadCatch m, Serialize a)
+    nullResultHandler :: (MonadCatch m, Serialize a) => ExecuteHandler m a FieldException
-        => FieldException
-        -> ExecutorT m a
     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

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.

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

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