{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Validation.Query.FragmentPreconditions
  ( checkFragmentPreconditions,
  )
where

import Control.Monad.Except (throwError)
import Data.Mergeable
import Data.Morpheus.Error.Fragment
  ( cannotSpreadWithinItself,
  )
import Data.Morpheus.Internal.Graph
  ( Edges,
    Graph,
    Node,
    cycleChecking,
  )
import Data.Morpheus.Internal.Utils
  ( selectOr,
  )
import Data.Morpheus.Types.Internal.AST
  ( Fragment (..),
    FragmentName,
    Fragments,
    RAW,
    Ref (..),
    Selection (..),
    SelectionContent (..),
    SelectionSet,
  )
import Data.Morpheus.Types.Internal.Validation
  ( BaseValidator,
    askFragments,
    checkUnused,
  )
import Relude

checkUnusedFragments :: SelectionSet RAW -> BaseValidator ()
checkUnusedFragments :: SelectionSet RAW -> BaseValidator ()
checkUnusedFragments SelectionSet RAW
selectionSet = do
  Fragments RAW
fragments <- Validator VALID (OperationContext RAW RAW) (Fragments RAW)
forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments
  HashMap FragmentName [Node FragmentName]
usages <- Fragments RAW
-> SelectionSet RAW
-> BaseValidator (HashMap FragmentName [Node FragmentName])
usedFragments Fragments RAW
fragments SelectionSet RAW
selectionSet
  HashMap FragmentName [Node FragmentName]
-> Fragments RAW -> Validator VALID (OperationContext RAW RAW) ()
forall k b (c :: * -> *) (t :: * -> *) a (s :: Stage) (s1 :: Stage)
       (s2 :: Stage).
(KeyOf k b, IsMap k c, Unused b, Foldable t) =>
c a -> t b -> Validator s (OperationContext s1 s2) ()
checkUnused HashMap FragmentName [Node FragmentName]
usages Fragments RAW
fragments

usedFragments :: Fragments RAW -> SelectionSet RAW -> BaseValidator (HashMap FragmentName [Node FragmentName])
usedFragments :: Fragments RAW
-> SelectionSet RAW
-> BaseValidator (HashMap FragmentName [Node FragmentName])
usedFragments Fragments RAW
fragments = [(FragmentName, [Node FragmentName])]
-> Validator
     VALID
     (OperationContext RAW RAW)
     (HashMap FragmentName [Node FragmentName])
forall k (m :: * -> *) v.
(Eq k, Hashable k, Monad m, Semigroup v) =>
[(k, v)] -> m (HashMap k v)
collect ([(FragmentName, [Node FragmentName])]
 -> Validator
      VALID
      (OperationContext RAW RAW)
      (HashMap FragmentName [Node FragmentName]))
-> (MergeMap 'True FieldName (Selection RAW)
    -> [(FragmentName, [Node FragmentName])])
-> MergeMap 'True FieldName (Selection RAW)
-> Validator
     VALID
     (OperationContext RAW RAW)
     (HashMap FragmentName [Node FragmentName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node FragmentName -> (FragmentName, [Node FragmentName]))
-> [Node FragmentName] -> [(FragmentName, [Node FragmentName])]
forall a b. (a -> b) -> [a] -> [b]
map Node FragmentName -> (FragmentName, [Node FragmentName])
forall name. Ref name -> (name, [Ref name])
toEntry ([Node FragmentName] -> [(FragmentName, [Node FragmentName])])
-> (MergeMap 'True FieldName (Selection RAW)
    -> [Node FragmentName])
-> MergeMap 'True FieldName (Selection RAW)
-> [(FragmentName, [Node FragmentName])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Selection RAW -> [Node FragmentName])
-> [Selection RAW] -> [Node FragmentName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FragmentName]
findAllUses ([Selection RAW] -> [Node FragmentName])
-> (MergeMap 'True FieldName (Selection RAW) -> [Selection RAW])
-> MergeMap 'True FieldName (Selection RAW)
-> [Node FragmentName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MergeMap 'True FieldName (Selection RAW) -> [Selection RAW]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
    toEntry :: Ref name -> (name, [Ref name])
toEntry (Ref name
x Position
y) = (name
x, [name -> Position -> Ref name
forall name. name -> Position -> Ref name
Ref name
x Position
y])
    findUsesSelectionContent :: SelectionContent RAW -> [Node FragmentName]
    findUsesSelectionContent :: SelectionContent RAW -> [Node FragmentName]
findUsesSelectionContent (SelectionSet SelectionSet RAW
selectionSet) =
      (Selection RAW -> [Node FragmentName])
-> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FragmentName]
findAllUses MergeMap 'True FieldName (Selection RAW)
SelectionSet RAW
selectionSet
    findUsesSelectionContent SelectionContent RAW
SelectionField = []
    findAllUses :: Selection RAW -> [Node FragmentName]
    findAllUses :: Selection RAW -> [Node FragmentName]
findAllUses Selection {SelectionContent RAW
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent :: SelectionContent RAW
selectionContent} =
      SelectionContent RAW -> [Node FragmentName]
findUsesSelectionContent SelectionContent RAW
selectionContent
    findAllUses (InlineFragment Fragment {SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet RAW
fragmentSelection}) =
      (Selection RAW -> [Node FragmentName])
-> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FragmentName]
findAllUses MergeMap 'True FieldName (Selection RAW)
SelectionSet RAW
fragmentSelection
    findAllUses (Spread Directives RAW
_ Ref {FragmentName
refName :: forall name. Ref name -> name
refName :: FragmentName
refName, Position
refPosition :: forall name. Ref name -> Position
refPosition :: Position
refPosition}) =
      [FragmentName -> Position -> Node FragmentName
forall name. name -> Position -> Ref name
Ref FragmentName
refName Position
refPosition] [Node FragmentName] -> [Node FragmentName] -> [Node FragmentName]
forall a. Semigroup a => a -> a -> a
<> [Node FragmentName]
searchInFragment
      where
        searchInFragment :: [Node FragmentName]
searchInFragment =
          [Node FragmentName]
-> (Fragment RAW -> [Node FragmentName])
-> FragmentName
-> Fragments RAW
-> [Node FragmentName]
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr
            []
            ((Selection RAW -> [Node FragmentName])
-> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FragmentName]
findAllUses (MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName])
-> (Fragment RAW -> MergeMap 'True FieldName (Selection RAW))
-> Fragment RAW
-> [Node FragmentName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fragment RAW -> MergeMap 'True FieldName (Selection RAW)
forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection)
            FragmentName
refName
            Fragments RAW
fragments

checkFragmentPreconditions :: SelectionSet RAW -> BaseValidator ()
checkFragmentPreconditions :: SelectionSet RAW -> BaseValidator ()
checkFragmentPreconditions SelectionSet RAW
selection =
  (BaseValidator (Graph FragmentName)
Validator VALID (OperationContext RAW RAW) (Graph FragmentName)
exploreSpreads Validator VALID (OperationContext RAW RAW) (Graph FragmentName)
-> (Graph FragmentName
    -> Validator VALID (OperationContext RAW RAW) ())
-> Validator VALID (OperationContext RAW RAW) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (NonEmpty (Node FragmentName)
 -> Validator VALID (OperationContext RAW RAW) ())
-> Graph FragmentName
-> Validator VALID (OperationContext RAW RAW) ()
forall (m :: * -> *) name.
(Applicative m, Eq name) =>
(NonEmpty (Ref name) -> m ()) -> Graph name -> m ()
cycleChecking (GQLError -> Validator VALID (OperationContext RAW RAW) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> Validator VALID (OperationContext RAW RAW) ())
-> (NonEmpty (Node FragmentName) -> GQLError)
-> NonEmpty (Node FragmentName)
-> Validator VALID (OperationContext RAW RAW) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Node FragmentName) -> GQLError
cannotSpreadWithinItself))
    Validator VALID (OperationContext RAW RAW) ()
-> Validator VALID (OperationContext RAW RAW) ()
-> Validator VALID (OperationContext RAW RAW) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SelectionSet RAW -> BaseValidator ()
checkUnusedFragments SelectionSet RAW
selection

exploreSpreads :: BaseValidator (Graph FragmentName)
exploreSpreads :: BaseValidator (Graph FragmentName)
exploreSpreads = (Fragment RAW -> Edges FragmentName)
-> [Fragment RAW] -> Graph FragmentName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fragment RAW -> Edges FragmentName
exploreFragmentSpreads ([Fragment RAW] -> Graph FragmentName)
-> (Fragments RAW -> [Fragment RAW])
-> Fragments RAW
-> Graph FragmentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fragments RAW -> [Fragment RAW]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Fragments RAW -> Graph FragmentName)
-> Validator VALID (OperationContext RAW RAW) (Fragments RAW)
-> Validator VALID (OperationContext RAW RAW) (Graph FragmentName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Validator VALID (OperationContext RAW RAW) (Fragments RAW)
forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments

exploreFragmentSpreads :: Fragment RAW -> Edges FragmentName
exploreFragmentSpreads :: Fragment RAW -> Edges FragmentName
exploreFragmentSpreads Fragment {FragmentName
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName :: FragmentName
fragmentName, SelectionSet RAW
fragmentSelection :: SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection, Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition :: Position
fragmentPosition} =
  (FragmentName -> Position -> Node FragmentName
forall name. name -> Position -> Ref name
Ref FragmentName
fragmentName Position
fragmentPosition, (Selection RAW -> [Node FragmentName])
-> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FragmentName]
forall a. ScanSpread a => a -> [Node FragmentName]
scanSpread MergeMap 'True FieldName (Selection RAW)
SelectionSet RAW
fragmentSelection)

class ScanSpread a where
  scanSpread :: a -> [Node FragmentName]

instance ScanSpread (Selection RAW) where
  scanSpread :: Selection RAW -> [Node FragmentName]
scanSpread Selection {SelectionContent RAW
selectionContent :: SelectionContent RAW
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent} =
    SelectionContent RAW -> [Node FragmentName]
forall a. ScanSpread a => a -> [Node FragmentName]
scanSpread SelectionContent RAW
selectionContent
  scanSpread (InlineFragment Fragment {SelectionSet RAW
fragmentSelection :: SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection}) =
    (Selection RAW -> [Node FragmentName])
-> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FragmentName]
forall a. ScanSpread a => a -> [Node FragmentName]
scanSpread MergeMap 'True FieldName (Selection RAW)
SelectionSet RAW
fragmentSelection
  scanSpread (Spread Directives RAW
_ Ref {FragmentName
refName :: FragmentName
refName :: forall name. Ref name -> name
refName, Position
refPosition :: Position
refPosition :: forall name. Ref name -> Position
refPosition}) =
    [FragmentName -> Position -> Node FragmentName
forall name. name -> Position -> Ref name
Ref FragmentName
refName Position
refPosition]

instance ScanSpread (SelectionContent RAW) where
  scanSpread :: SelectionContent RAW -> [Node FragmentName]
scanSpread SelectionContent RAW
SelectionField = []
  scanSpread (SelectionSet SelectionSet RAW
selectionSet) =
    (Selection RAW -> [Node FragmentName])
-> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FragmentName]
forall a. ScanSpread a => a -> [Node FragmentName]
scanSpread MergeMap 'True FieldName (Selection RAW)
SelectionSet RAW
selectionSet