mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-21 14:31:55 +03:00
142 lines
5.0 KiB
Haskell
142 lines
5.0 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Hasura.GraphQL.Validate
|
|
( validateGQ
|
|
, GraphQLRequest
|
|
) where
|
|
|
|
import Data.Has
|
|
import Hasura.Prelude
|
|
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Language.GraphQL.Draft.Syntax as G
|
|
|
|
import Hasura.GraphQL.Schema
|
|
import Hasura.GraphQL.Transport.HTTP.Protocol
|
|
import Hasura.GraphQL.Validate.Context
|
|
import Hasura.GraphQL.Validate.Field
|
|
import Hasura.GraphQL.Validate.InputValue
|
|
import Hasura.GraphQL.Validate.Types
|
|
import Hasura.RQL.Types
|
|
|
|
getTypedOp
|
|
:: (MonadError QErr m)
|
|
=> Maybe OperationName
|
|
-> [G.SelectionSet]
|
|
-> [G.TypedOperationDefinition]
|
|
-> m G.TypedOperationDefinition
|
|
getTypedOp opNameM selSets opDefs =
|
|
case (opNameM, selSets, opDefs) of
|
|
(Just opName, [], _) -> do
|
|
let n = _unOperationName opName
|
|
opDefM = find (\opDef -> G._todName opDef == Just n) opDefs
|
|
onNothing opDefM $ throwVE $
|
|
"no such operation found in the document: " <> showName n
|
|
(Just _, _, _) ->
|
|
throwVE $ "operationName cannot be used when " <>
|
|
"an anonymous operation exists in the document"
|
|
(Nothing, [selSet], []) ->
|
|
return $ G.TypedOperationDefinition
|
|
G.OperationTypeQuery Nothing [] [] selSet
|
|
(Nothing, [], [opDef]) ->
|
|
return opDef
|
|
(Nothing, _, _) ->
|
|
throwVE $ "exactly one operation has to be present " <>
|
|
"in the document when operationName is not specified"
|
|
|
|
-- For all the variables defined there will be a value in the final map
|
|
-- If no default, not in variables and nullable, then null value
|
|
getAnnVarVals
|
|
:: ( MonadReader r m, Has TypeMap r
|
|
, MonadError QErr m
|
|
)
|
|
=> [G.VariableDefinition]
|
|
-> VariableValues
|
|
-> m AnnVarVals
|
|
getAnnVarVals varDefsL inpVals = do
|
|
|
|
varDefs <- onLeft (mkMapWith G._vdVariable varDefsL) $ \dups ->
|
|
throwVE $ "the following variables are defined more than once: " <>
|
|
showVars dups
|
|
|
|
let unexpectedVars = filter (not . (`Map.member` varDefs)) $ Map.keys inpVals
|
|
|
|
unless (null unexpectedVars) $
|
|
throwVE $ "unexpected variables in variableValues: " <>
|
|
showVars unexpectedVars
|
|
|
|
forM varDefs $ \(G.VariableDefinition var ty defM) -> do
|
|
let baseTy = getBaseTy ty
|
|
baseTyInfo <- getTyInfoVE baseTy
|
|
-- check that the variable is defined on input types
|
|
when (isObjTy baseTyInfo) $ throwVE $ objTyErrMsg baseTy
|
|
|
|
let defM' = bool (defM <|> Just G.VCNull) defM $ G.isNotNull ty
|
|
annDefM <- withPathK "defaultValue" $
|
|
mapM (validateInputValue constValueParser ty) defM'
|
|
let inpValM = Map.lookup var inpVals
|
|
annInpValM <- withPathK "variableValues" $
|
|
mapM (validateInputValue jsonParser ty) inpValM
|
|
let varValM = annInpValM <|> annDefM
|
|
onNothing varValM $ throwVE $ "expecting a value for non-null type: "
|
|
<> G.showGT ty <> " in variableValues"
|
|
where
|
|
objTyErrMsg namedTy =
|
|
"variables can only be defined on input types"
|
|
<> "(enums, scalars, input objects), but "
|
|
<> showNamedTy namedTy <> " is an object type"
|
|
|
|
showVars :: (Functor f, Foldable f) => f G.Variable -> Text
|
|
showVars = showNames . fmap G.unVariable
|
|
|
|
validateFrag
|
|
:: (MonadError QErr m, MonadReader r m, Has TypeMap r)
|
|
=> G.FragmentDefinition -> m FragDef
|
|
validateFrag (G.FragmentDefinition n onTy dirs selSet) = do
|
|
unless (null dirs) $ throwVE
|
|
"unexpected directives at fragment definition"
|
|
tyInfo <- getTyInfoVE onTy
|
|
objTyInfo <- onNothing (getObjTyM tyInfo) $ throwVE
|
|
"fragments can only be defined on object types"
|
|
return $ FragDef n objTyInfo selSet
|
|
|
|
-- {-# SCC validateGQ #-}
|
|
validateGQ
|
|
:: (MonadError QErr m, MonadReader GCtx m)
|
|
=> GraphQLRequest
|
|
-> m (G.OperationType, SelSet)
|
|
validateGQ (GraphQLRequest opNameM q varValsM) = do
|
|
|
|
-- get the operation that needs to be evaluated
|
|
opDef <- getTypedOp opNameM selSets opDefs
|
|
|
|
ctx <- ask
|
|
-- get the operation root
|
|
opRoot <- case G._todType opDef of
|
|
G.OperationTypeQuery -> return $ _gQueryRoot ctx
|
|
G.OperationTypeMutation ->
|
|
onNothing (_gMutRoot ctx) $ throwVE "no mutations exist"
|
|
G.OperationTypeSubscription ->
|
|
onNothing (_gSubRoot ctx) $ throwVE "no subscriptions exist"
|
|
|
|
-- annotate the variables of this operation
|
|
annVarVals <- getAnnVarVals (G._todVariableDefinitions opDef) $
|
|
fromMaybe Map.empty varValsM
|
|
|
|
-- annotate the fragments
|
|
fragDefs <- onLeft (mkMapWith G._fdName fragDefsL) $ \dups ->
|
|
throwVE $ "the following fragments are defined more than once: " <>
|
|
showNames dups
|
|
annFragDefs <- mapM validateFrag fragDefs
|
|
|
|
-- build a validation ctx
|
|
let valCtx = ValidationCtx (_gTypes ctx) annVarVals annFragDefs
|
|
|
|
selSet <- flip runReaderT valCtx $ denormSelSet [] opRoot $
|
|
G._todSelectionSet opDef
|
|
return (G._todType opDef, selSet)
|
|
where
|
|
(selSets, opDefs, fragDefsL) = G.partitionExDefs $ unGraphQLQuery q
|