{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Data.Morpheus.Validation.Selection
( validateSelectionSet
) where
import Data.Morpheus.Error.Selection (cannotQueryField, duplicateQuerySelections,
hasNoSubfields)
import Data.Morpheus.Types.Internal.AST.Operator (ValidVariables)
import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawSelection (..),
RawSelection' (..), RawSelectionSet)
import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet)
import Data.Morpheus.Types.Internal.Base (EnhancedKey (..))
import Data.Morpheus.Types.Internal.Data (DataField (..), DataOutputObject, DataType (..),
DataTypeKind (..), DataTypeLib (..))
import Data.Morpheus.Types.Internal.Validation (Validation)
import Data.Morpheus.Validation.Arguments (validateArguments)
import Data.Morpheus.Validation.Spread (castFragmentType, resolveSpread)
import Data.Morpheus.Validation.Utils.Selection (lookupFieldAsSelectionSet, lookupSelectionField,
lookupUnionTypes, notObject)
import Data.Morpheus.Validation.Utils.Utils (checkNameCollision)
import Data.Text (Text)
checkDuplicatesOn :: DataOutputObject -> SelectionSet -> Validation SelectionSet
checkDuplicatesOn DataType {typeName = name'} keys = checkNameCollision enhancedKeys (map fst keys) error' >> pure keys
where
error' = duplicateQuerySelections name'
enhancedKeys = map selToKey keys
selToKey (key', Selection {selectionPosition = position'}) = EnhancedKey key' position'
clusterUnionSelection ::
FragmentLib -> Text -> [DataOutputObject] -> (Text, RawSelection) -> Validation ([Fragment], SelectionSet)
clusterUnionSelection fragments' type' possibleTypes' = splitFrag
where
packFragment fragment' = return ([fragment'], [])
typeNames = map typeName possibleTypes'
splitFrag :: (Text, RawSelection) -> Validation ([Fragment], SelectionSet)
splitFrag (_, Spread reference') = resolveSpread fragments' typeNames reference' >>= packFragment
splitFrag ("__typename", RawSelectionField RawSelection' {rawSelectionPosition = position'}) =
return
( []
, [ ( "__typename"
, Selection {selectionRec = SelectionField, selectionArguments = [], selectionPosition = position'})
])
splitFrag (key', RawSelectionSet RawSelection' {rawSelectionPosition = position'}) =
Left $ cannotQueryField key' type' position'
splitFrag (key', RawSelectionField RawSelection' {rawSelectionPosition = position'}) =
Left $ cannotQueryField key' type' position'
splitFrag (key', RawAlias {rawAliasPosition = position'}) = Left $ cannotQueryField key' type' position'
splitFrag (_, InlineFragment fragment') =
castFragmentType Nothing (fragmentPosition fragment') typeNames fragment' >>= packFragment
categorizeTypes :: [DataOutputObject] -> [Fragment] -> [(DataOutputObject, [Fragment])]
categorizeTypes types' fragments' = map categorizeType types'
where
categorizeType :: DataOutputObject -> (DataOutputObject, [Fragment])
categorizeType type' = (type', filter matches fragments')
where
matches fragment' = fragmentType fragment' == typeName type'
flatTuple :: [([a], [b])] -> ([a], [b])
flatTuple list' = (concatMap fst list', concatMap snd list')
validateSelectionSet ::
DataTypeLib
-> FragmentLib
-> Text
-> ValidVariables
-> DataOutputObject
-> RawSelectionSet
-> Validation SelectionSet
validateSelectionSet lib' fragments' operatorName variables = __validate
where
__validate dataType'@DataType {typeName = typeName'} selectionSet' =
concat <$> mapM validateSelection selectionSet' >>= checkDuplicatesOn dataType'
where
validateFragment Fragment {fragmentSelection = selection'} = __validate dataType' selection'
getValidationData key' RawSelection' {rawSelectionArguments, rawSelectionPosition} = do
selectionField <- lookupSelectionField rawSelectionPosition key' dataType'
arguments' <-
validateArguments
lib'
operatorName
variables
(key', selectionField)
rawSelectionPosition
rawSelectionArguments
return (selectionField, arguments')
validateSelection :: (Text, RawSelection) -> Validation SelectionSet
validateSelection (key', RawAlias {rawAliasSelection = rawSelection', rawAliasPosition = position'}) =
fmap processSingleSelection <$> validateSelection rawSelection'
where
processSingleSelection (selKey', selection') =
( key'
, selection'
{ selectionRec = SelectionAlias {aliasFieldName = selKey', aliasSelection = selectionRec selection'}
, selectionPosition = position'
})
validateSelection (key', RawSelectionSet fullRawSelection'@RawSelection' { rawSelectionRec = rawSelectors
, rawSelectionPosition = position'
}) = do
(dataField', arguments') <- getValidationData key' fullRawSelection'
case fieldKind dataField' of
KindUnion -> do
(categories', __typename') <- clusterTypes
mapM (validateCluster __typename') categories' >>= returnSelection arguments' . UnionSelection
where clusterTypes = do
unionTypes' <- lookupUnionTypes position' key' lib' dataField'
(spreads', __typename') <-
flatTuple <$> mapM (clusterUnionSelection fragments' typeName' unionTypes') rawSelectors
return (categorizeTypes unionTypes' spreads', __typename')
validateCluster :: SelectionSet -> (DataOutputObject, [Fragment]) -> Validation (Text, SelectionSet)
validateCluster sysSelection' (type', frags') = do
selection' <- __validate type' (concatMap fragmentSelection frags')
return (typeName type', sysSelection' ++ selection')
KindObject -> do
fieldType' <- lookupFieldAsSelectionSet position' key' lib' dataField'
__validate fieldType' rawSelectors >>= returnSelection arguments' . SelectionSet
_ -> Left $ hasNoSubfields key' (fieldType dataField') position'
where
returnSelection arguments' selection' =
pure
[ ( key'
, Selection
{selectionArguments = arguments', selectionRec = selection', selectionPosition = position'})
]
validateSelection (key', RawSelectionField fullRawSelection'@RawSelection' {rawSelectionPosition = position'}) = do
(dataField', arguments') <- getValidationData key' fullRawSelection'
_ <- notObject (key', position') dataField'
pure
[ ( key'
, Selection
{selectionArguments = arguments', selectionRec = SelectionField, selectionPosition = position'})
]
validateSelection (_, Spread reference') = resolveSpread fragments' [typeName'] reference' >>= validateFragment
validateSelection (_, InlineFragment fragment') =
castFragmentType Nothing (fragmentPosition fragment') [typeName'] fragment' >>= validateFragment