diff options
Diffstat (limited to 'src/Language/GraphQL/Validate')
| -rw-r--r-- | src/Language/GraphQL/Validate/Rules.hs | 75 |
1 files changed, 41 insertions, 34 deletions
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 2d7adba..3fef94d 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -50,14 +50,15 @@ import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT) import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) import Data.Bifunctor (first) -import Data.Foldable (find, fold, foldl', toList) +import Data.Foldable (Foldable(..), find) import qualified Data.HashMap.Strict as HashMap import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet -import Data.List (groupBy, sortBy, sortOn) +import Data.List (sortBy) import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty import Data.Ord (comparing) import Data.Sequence (Seq(..), (|>)) import qualified Data.Sequence as Seq @@ -253,14 +254,16 @@ findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location]) -> Full.Location -> String -> RuleT m -findDuplicates filterByName thisLocation errorMessage = do - ast' <- asks ast - let locations' = foldr filterByName [] ast' - if length locations' > 1 && head locations' == thisLocation - then pure $ error' locations' - else lift mempty +findDuplicates filterByName thisLocation errorMessage = + asks ast >>= go . foldr filterByName [] where - error' locations' = Error + go locations' = + case locations' of + headLocation : otherLocations -- length locations' > 1 + | not $ null otherLocations + , headLocation == thisLocation -> pure $ makeError locations' + _ -> lift mempty + makeError locations' = Error { message = errorMessage , locations = locations' } @@ -530,16 +533,20 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule -- used, the expected metadata or behavior becomes ambiguous, therefore only one -- of each directive is allowed per location. uniqueDirectiveNamesRule :: forall m. Rule m -uniqueDirectiveNamesRule = DirectivesRule - $ const $ lift . filterDuplicates extract "directive" - where - extract (Full.Directive directiveName _ location') = - (directiveName, location') - -groupSorted :: forall a. (a -> Text) -> [a] -> [[a]] -groupSorted getName = groupBy equalByName . sortOn getName +uniqueDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do + definitions' <- asks $ Schema.directives . schema + let filterNonRepeatable = flip HashSet.member nonRepeatableSet + . getField @"name" + nonRepeatableSet = + HashMap.foldlWithKey foldNonRepeatable HashSet.empty definitions' + lift $ filterDuplicates extract "directive" + $ filter filterNonRepeatable directives' where - equalByName lhs rhs = getName lhs == getName rhs + foldNonRepeatable hashSet directiveName' (Schema.Directive _ _ False _) = + HashSet.insert directiveName' hashSet + foldNonRepeatable hashSet _ _ = hashSet + extract (Full.Directive directiveName' _ location') = + (directiveName', location') filterDuplicates :: forall a . (a -> (Text, Full.Location)) @@ -549,12 +556,12 @@ filterDuplicates :: forall a filterDuplicates extract nodeType = Seq.fromList . fmap makeError . filter ((> 1) . length) - . groupSorted getName + . NonEmpty.groupAllWith getName where getName = fst . extract makeError directives' = Error - { message = makeMessage $ head directives' - , locations = snd . extract <$> directives' + { message = makeMessage $ NonEmpty.head directives' + , locations = snd . extract <$> toList directives' } makeMessage directive = concat [ "There can be only one " @@ -833,7 +840,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule . Schema.directives . schema Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments case available of - Just (Schema.Directive _ _ definitions) + Just (Schema.Directive _ definitions _ _) | not $ HashMap.member argumentName definitions -> pure $ makeError argumentName directiveName location' _ -> lift mempty @@ -854,18 +861,18 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule knownDirectiveNamesRule :: Rule m knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do definitions' <- asks $ Schema.directives . schema - let directiveSet = HashSet.fromList $ fmap directiveName directives' - let definitionSet = HashSet.fromList $ HashMap.keys definitions' - let difference = HashSet.difference directiveSet definitionSet - let undefined' = filter (definitionFilter difference) directives' + let directiveSet = HashSet.fromList $ fmap (getField @"name") directives' + definitionSet = HashSet.fromList $ HashMap.keys definitions' + difference = HashSet.difference directiveSet definitionSet + undefined' = filter (definitionFilter difference) directives' lift $ Seq.fromList $ makeError <$> undefined' where + definitionFilter :: HashSet Full.Name -> Full.Directive -> Bool definitionFilter difference = flip HashSet.member difference - . directiveName - directiveName (Full.Directive directiveName' _ _) = directiveName' - makeError (Full.Directive directiveName' _ location') = Error - { message = errorMessage directiveName' - , locations = [location'] + . getField @"name" + makeError Full.Directive{..} = Error + { message = errorMessage name + , locations = [location] } errorMessage directiveName' = concat [ "Unknown directive \"@" @@ -913,7 +920,7 @@ directivesInValidLocationsRule = DirectivesRule directivesRule maybeDefinition <- asks $ HashMap.lookup directiveName . Schema.directives . schema case maybeDefinition of - Just (Schema.Directive _ allowedLocations _) + Just (Schema.Directive _ _ _ allowedLocations) | directiveLocation `notElem` allowedLocations -> pure $ Error { message = errorMessage directiveName directiveLocation , locations = [location] @@ -943,7 +950,7 @@ providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule available <- asks $ HashMap.lookup directiveName . Schema.directives . schema case available of - Just (Schema.Directive _ _ definitions) -> + Just (Schema.Directive _ definitions _ _) -> let forEach = go (directiveMessage directiveName) arguments location' in lift $ HashMap.foldrWithKey forEach Seq.empty definitions _ -> lift mempty @@ -1411,7 +1418,7 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case let Full.Directive directiveName arguments _ = directive directiveDefinitions <- lift $ asks $ Schema.directives . schema case HashMap.lookup directiveName directiveDefinitions of - Just (Schema.Directive _ _ directiveArguments) -> + Just (Schema.Directive _ directiveArguments _ _) -> mapArguments variables directiveArguments arguments Nothing -> pure mempty mapArguments variables argumentTypes = fmap fold |