graphql-engine/server/src-lib/Hasura/GraphQL/Validate/Field.hs

336 lines
10 KiB
Haskell
Raw Normal View History

2018-06-27 16:11:32 +03:00
module Hasura.GraphQL.Validate.Field
( ArgsMap
, Field(..)
, SelSet
, denormSelSet
) where
import Hasura.Prelude
import qualified Data.Aeson as J
import qualified Data.Aeson.Casing as J
import qualified Data.Aeson.TH as J
import qualified Data.HashMap.Strict as Map
import qualified Data.HashMap.Strict.InsOrd.Extended as OMap
import qualified Data.List as L
import qualified Data.Sequence as Seq
import qualified Data.Sequence.NonEmpty as NE
import qualified Data.Text as T
import qualified Language.GraphQL.Draft.Syntax as G
2018-06-27 16:11:32 +03:00
import Hasura.GraphQL.Validate.Context
import Hasura.GraphQL.Validate.InputValue
import Hasura.GraphQL.Validate.Types
import Hasura.RQL.Types
import Hasura.SQL.Value
2018-06-27 16:11:32 +03:00
-- data ScalarInfo
-- = SIBuiltin !GBuiltin
-- | SICustom !PGColType
-- deriving (Show, Eq)
-- data GBuiltin
-- = GInt
-- | GFloat
-- | GBoolean
-- | GString
-- deriving (Show, Eq)
data TypedOperation
= TypedOperation
{ _toType :: !G.OperationType
, _toName :: !(Maybe G.Name)
, _toSelectionSet :: ![Field]
} deriving (Show, Eq)
type ArgsMap = Map.HashMap G.Name AnnInpVal
2018-06-27 16:11:32 +03:00
type SelSet = Seq.Seq Field
data Field
= Field
{ _fAlias :: !G.Alias
, _fName :: !G.Name
, _fType :: !G.NamedType
, _fArguments :: !ArgsMap
, _fSelSet :: !SelSet
} deriving (Eq, Show)
$(J.deriveToJSON (J.aesonDrop 2 J.camelCase){J.omitNothingFields=True}
''Field
)
-- newtype FieldMapAlias
-- = FieldMapAlias
-- { unFieldMapAlias :: Map.HashMap G.Alias (FieldG FieldMapAlias)
-- } deriving (Show, Eq)
-- newtype FieldMapName
-- = FieldMapName
-- { unFieldMapName :: Map.HashMap G.Name (NE.NonEmpty (FieldG FieldMapName))
-- } deriving (Show, Eq)
-- type Field = FieldG FieldMapAlias
-- type FieldGrouped = FieldG FieldMapName
-- toFieldGrouped :: Field -> FieldGrouped
-- toFieldGrouped =
-- fmap groupFields
-- where
-- groupFields m =
-- FieldMapName $ groupTuples $
-- flip map (Map.elems $ unFieldMapAlias m) $ \fld ->
-- (_fName fld, toFieldGrouped fld)
data FieldGroupSrc
= FGSFragSprd !G.Name
| FGSInlnFrag
deriving (Show, Eq)
data FieldGroup
= FieldGroup
{ _fgSource :: !FieldGroupSrc
, _fgFields :: !(Seq.Seq Field)
} deriving (Show, Eq)
-- data GLoc
-- = GLoc
-- { _glLine :: !Int
-- , _glColumn :: !Int
-- } deriving (Show, Eq)
-- data GErr
-- = GErr
-- { _geMessage :: !Text
-- , _geLocations :: ![GLoc]
-- } deriving (Show, Eq)
-- throwGE :: (MonadError QErr m) => Text -> m a
-- throwGE msg = throwError $ QErr msg []
withDirectives
:: ( MonadReader ValidationCtx m
, MonadError QErr m)
=> [G.Directive]
-> m a
-> m (Maybe a)
withDirectives dirs act = do
dirDefs <- onLeft (mkMapWith G._dName dirs) $ \dups ->
throwVE $ "the following directives are used more than once: " <>
showNames dups
procDirs <- flip Map.traverseWithKey dirDefs $ \name dir ->
withPathK (G.unName name) $ do
dirInfo <- onNothing (Map.lookup (G._dName dir) defDirectivesMap) $
throwVE $ "unexpected directive: " <> showName name
procArgs <- withPathK "args" $ processArgs (_diParams dirInfo)
(G._dArguments dir)
getIfArg procArgs
let shouldSkip = fromMaybe False $ Map.lookup "skip" procDirs
shouldInclude = fromMaybe True $ Map.lookup "include" procDirs
if not shouldSkip && shouldInclude
then Just <$> act
else return Nothing
where
getIfArg m = do
val <- onNothing (Map.lookup "if" m) $ throw500
"missing if argument in the directive"
case _aivValue val of
AGScalar _ (Just (PGValBoolean v)) -> return v
_ -> throw500 "did not find boolean scalar for if argument"
2018-06-27 16:11:32 +03:00
denormSel
:: ( MonadReader ValidationCtx m
, MonadError QErr m)
=> [G.Name] -- visited fragments
-> ObjTyInfo -- parent type info
-> G.Selection
-> m (Maybe (Either Field FieldGroup))
denormSel visFrags parObjTyInfo sel = case sel of
G.SelectionField fld -> withPathK (G.unName $ G._fName fld) $ do
2018-06-27 16:11:32 +03:00
fldInfo <- getFieldInfo parObjTyInfo $ G._fName fld
fmap Left <$> denormFld visFrags fldInfo fld
G.SelectionFragmentSpread fragSprd ->
withPathK (G.unName $ G._fsName fragSprd) $
2018-06-27 16:11:32 +03:00
fmap Right <$> denormFrag visFrags parTy fragSprd
G.SelectionInlineFragment inlnFrag ->
withPathK "inlineFragment" $
2018-06-27 16:11:32 +03:00
fmap Right <$> denormInlnFrag visFrags parObjTyInfo inlnFrag
where
parTy = _otiName parObjTyInfo
processArgs
:: ( MonadReader ValidationCtx m
, MonadError QErr m)
=> ParamMap
2018-06-27 16:11:32 +03:00
-> [G.Argument]
-> m ArgsMap
processArgs fldParams argsL = do
2018-06-27 16:11:32 +03:00
args <- onLeft (mkMapWith G._aName argsL) $ \dups ->
throwVE $ "the following arguments are defined more than once: " <>
showNames dups
let requiredParams = Map.filter (G.isNotNull . _iviType) fldParams
inpArgs <- forM args $ \(G.Argument argName argVal) ->
withPathK (G.unName argName) $ do
argTy <- getArgTy argName
validateInputValue valueParser argTy argVal
2018-06-27 16:11:32 +03:00
forM_ requiredParams $ \argDef -> do
let param = _iviName argDef
onNothing (Map.lookup param inpArgs) $ throwVE $ mconcat
[ "the required argument ", showName param, " is missing"]
2018-06-27 16:11:32 +03:00
return inpArgs
where
getArgTy argName =
onNothing (_iviType <$> Map.lookup argName fldParams) $ throwVE $
"no such argument " <> showName argName <> " is expected"
2018-06-27 16:11:32 +03:00
denormFld
:: ( MonadReader ValidationCtx m
, MonadError QErr m)
=> [G.Name] -- visited fragments
-> ObjFldInfo
-> G.Field
-> m (Maybe Field)
denormFld visFrags fldInfo (G.Field aliasM name args dirs selSet) = do
let fldTy = _fiTy fldInfo
fldBaseTy = getBaseTy fldTy
fldTyInfo <- getTyInfo fldBaseTy
argMap <- withPathK "args" $ processArgs (_fiParams fldInfo) args
2018-06-27 16:11:32 +03:00
fields <- case (fldTyInfo, selSet) of
(TIObj _, []) ->
throwVE $ "field " <> showName name <> " of type "
<> G.showGT fldTy <> " must have a selection of subfields"
(TIObj fldObjTyInfo, _) ->
denormSelSet visFrags fldObjTyInfo selSet
(TIScalar _, []) -> return Seq.empty
(TIEnum _, []) -> return Seq.empty
(TIInpObj _, _) ->
throwVE $ "internal error: unexpected input type for field: "
<> showName name
-- when scalar/enum and no empty set
(_, _) ->
throwVE $ "field " <> showName name <> " must not have a "
<> "selection since type " <> G.showGT fldTy <> " has no subfields"
withPathK "directives" $ withDirectives dirs $ return $
2018-06-27 16:11:32 +03:00
Field (fromMaybe (G.Alias name) aliasM) name fldBaseTy argMap fields
denormInlnFrag
:: ( MonadReader ValidationCtx m
, MonadError QErr m)
=> [G.Name] -- visited fragments
-> ObjTyInfo -- type information of the field
-> G.InlineFragment
-> m (Maybe FieldGroup)
denormInlnFrag visFrags fldTyInfo inlnFrag = do
let fldTy = _otiName fldTyInfo
let fragTy = fromMaybe fldTy tyM
when (fldTy /= fragTy) $
throwVE $ "inline fragment is expected on type " <>
showNamedTy fldTy <> " but found " <> showNamedTy fragTy
withPathK "directives" $ withDirectives directives $
fmap (FieldGroup FGSInlnFrag) $ denormSelSet visFrags fldTyInfo selSet
2018-06-27 16:11:32 +03:00
where
G.InlineFragment tyM directives selSet = inlnFrag
denormSelSet
:: ( MonadReader ValidationCtx m
, MonadError QErr m)
=> [G.Name] -- visited fragments
-> ObjTyInfo
-> G.SelectionSet
-> m (Seq.Seq Field)
denormSelSet visFrags fldTyInfo selSet =
withPathK "selectionSet" $ do
resFlds <- catMaybes <$> mapM (denormSel visFrags fldTyInfo) selSet
mergeFields $ foldl' flatten Seq.empty resFlds
2018-06-27 16:11:32 +03:00
where
flatten s (Left fld) = s Seq.|> fld
flatten s (Right (FieldGroup _ flds)) =
s Seq.>< flds
mergeFields
:: ( MonadReader ValidationCtx m
, MonadError QErr m)
=> Seq.Seq Field
-> m (Seq.Seq Field)
mergeFields flds =
fmap Seq.fromList $ forM fldGroups $ \fieldGroup -> do
newFld <- checkMergeability fieldGroup
childFields <- mergeFields $ foldl' (\l f -> l Seq.>< _fSelSet f) Seq.empty
$ NE.toSeq fieldGroup
2018-06-27 16:11:32 +03:00
return $ newFld {_fSelSet = childFields}
where
fldGroups = OMap.elems $ OMap.groupListWith _fAlias flds
-- can a group be merged?
checkMergeability fldGroup = do
let groupedFlds = toList $ NE.toSeq fldGroup
fldNames = L.nub $ map _fName groupedFlds
args = L.nub $ map _fArguments groupedFlds
fld = NE.head fldGroup
fldAl = _fAlias fld
when (length fldNames > 1) $
throwVE $ "cannot merge different fields under the same alias ("
<> showName (G.unAlias fldAl) <> "): "
<> showNames fldNames
when (length args > 1) $
throwVE $ "cannot merge fields with different arguments"
<> " under the same alias: "
<> showName (G.unAlias fldAl)
return fld
denormFrag
:: ( MonadReader ValidationCtx m
, MonadError QErr m)
=> [G.Name] -- visited fragments
-> G.NamedType -- parent type
-> G.FragmentSpread
-> m (Maybe FieldGroup)
denormFrag visFrags parTy (G.FragmentSpread name directives) = do
-- check for cycles
when (name `elem` visFrags) $
throwVE $ "cannot spread fragment " <> showName name
<> " within itself via "
2018-06-27 16:11:32 +03:00
<> T.intercalate "," (map G.unName visFrags)
(FragDef _ fragTyInfo selSet) <- getFragInfo
let fragTy = _otiName fragTyInfo
-- we don't have unions or interfaces so we can get away with equality
when (fragTy /= parTy) $
throwVE $ "cannot spread fragment " <> showName name <> " defined on " <>
showNamedTy fragTy <> " when selecting fields of type " <> showNamedTy parTy
resFlds <- denormSelSet (name:visFrags) fragTyInfo selSet
2018-06-27 16:11:32 +03:00
withPathK "directives" $ withDirectives directives $
return $ FieldGroup (FGSFragSprd name) resFlds
where
getFragInfo = do
dctx <- ask
onNothing (Map.lookup name $ _vcFragDefMap dctx) $
throwVE $ "fragment '" <> G.unName name <> "' not found"