graphql/src/Language/GraphQL/Validate.hs

125 lines
5.0 KiB
Haskell
Raw Normal View History

2020-07-20 21:29:12 +02:00
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
2020-07-24 21:34:31 +02:00
-- | GraphQL validator.
2020-07-20 21:29:12 +02:00
module Language.GraphQL.Validate
( Error(..)
, Path(..)
, document
, module Language.GraphQL.Validate.Rules
) where
import Control.Monad (foldM)
import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
import Data.Foldable (fold, foldrM)
2020-07-20 21:29:12 +02:00
import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document
import Language.GraphQL.Type.Internal
import Language.GraphQL.Type.Schema (Schema(..))
2020-07-20 21:29:12 +02:00
import Language.GraphQL.Validate.Rules
import Language.GraphQL.Validate.Validation
2020-07-20 21:29:12 +02:00
type ValidateT m = Reader (Validation m) (Seq Error)
2020-07-20 21:29:12 +02:00
2020-07-24 21:34:31 +02:00
-- | Validates a document and returns a list of found errors. If the returned
-- list is empty, the document is valid.
document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
2020-07-20 21:29:12 +02:00
document schema' rules' document' =
runReader (foldrM go Seq.empty document') context
where
context = Validation
2020-07-20 21:29:12 +02:00
{ ast = document'
, schema = schema'
, types = collectReferencedTypes schema'
2020-07-20 21:29:12 +02:00
, rules = rules'
}
go definition' accumulator = (accumulator ><) <$> definition definition'
definition :: forall m. Definition -> ValidateT m
2020-09-07 22:01:49 +02:00
definition definition'
| ExecutableDefinition executableDefinition' <- definition'
= visitChildSelections ruleFilter
$ executableDefinition executableDefinition'
| otherwise = asks rules >>= foldM ruleFilter Seq.empty
2020-07-20 21:29:12 +02:00
where
2020-09-07 22:01:49 +02:00
ruleFilter accumulator (DefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule definition'
2020-09-07 22:01:49 +02:00
ruleFilter accumulator _ = pure accumulator
runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
runRule accumulator (Just error') = pure $ accumulator |> error'
runRule accumulator Nothing = pure accumulator
2020-07-20 21:29:12 +02:00
executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
executableDefinition (DefinitionOperation definition') =
operationDefinition definition'
executableDefinition (DefinitionFragment definition') =
fragmentDefinition definition'
operationDefinition :: forall m. OperationDefinition -> ValidateT m
operationDefinition operation =
let selectionSet = getSelectionSet operation
2020-09-07 22:01:49 +02:00
in visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
where
2020-08-28 08:32:21 +02:00
ruleFilter accumulator (OperationDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule operation
ruleFilter accumulator _ = pure accumulator
getSelectionSet (SelectionSet selectionSet _) = selectionSet
getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet
2020-07-20 21:29:12 +02:00
2020-09-07 22:01:49 +02:00
visitChildSelections :: forall m
. (Seq Error -> Rule m -> ValidateT m)
-> ValidateT m
-> ValidateT m
visitChildSelections ruleFilter children' = do
rules' <- asks rules
applied <- foldM ruleFilter Seq.empty rules'
children <- children'
pure $ children >< applied
selection :: forall m. Selection -> ValidateT m
selection selection'
2020-09-07 22:01:49 +02:00
| FragmentSpreadSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ fragmentSpread fragmentSelection
| Field _ _ _ _ selectionSet _ <- selection' =
2020-09-07 22:01:49 +02:00
visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
| InlineFragmentSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ inlineFragment fragmentSelection
where
ruleFilter accumulator (SelectionRule rule) =
mapReaderT (runRule accumulator) $ rule selection'
ruleFilter accumulator _ = pure accumulator
2020-09-07 22:01:49 +02:00
inlineFragment :: forall m. InlineFragment -> ValidateT m
inlineFragment fragment@(InlineFragment _ _ selections _) =
visitChildSelections ruleFilter $ traverseSelectionSet selections
where
ruleFilter accumulator (FragmentRule _ inlineRule) =
mapReaderT (runRule accumulator) $ inlineRule fragment
ruleFilter accumulator _ = pure accumulator
fragmentSpread :: forall m. FragmentSpread -> ValidateT m
fragmentSpread fragment =
asks rules >>= foldM ruleFilter Seq.empty
where
ruleFilter accumulator (FragmentSpreadRule rule) =
mapReaderT (runRule accumulator) $ rule fragment
ruleFilter accumulator _ = pure accumulator
traverseSelectionSet :: Traversable t => forall m. t Selection -> ValidateT m
traverseSelectionSet = fmap fold . traverse selection
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
fragmentDefinition fragment@(FragmentDefinition _ _ _ selectionSet _) =
2020-09-07 22:01:49 +02:00
visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
2020-08-28 08:32:21 +02:00
where
ruleFilter accumulator (FragmentDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule fragment
2020-09-07 22:01:49 +02:00
ruleFilter accumulator (FragmentRule definitionRule _) =
mapReaderT (runRule accumulator) $ definitionRule fragment
2020-08-28 08:32:21 +02:00
ruleFilter accumulator _ = pure accumulator