mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 12:31:52 +03:00
e01008413e
This fix is a little ugly, but it’s the only simple solution without a significant refactoring that restructures the relationship between GraphQL/Validate and GraphQL/Resolve. The ugliness should go away if we implement something like #2801.
412 lines
13 KiB
Haskell
412 lines
13 KiB
Haskell
module Hasura.GraphQL.Execute
|
|
( GQExecPlan(..)
|
|
|
|
, ExecPlanPartial
|
|
, getExecPlanPartial
|
|
|
|
, ExecOp(..)
|
|
, ExecPlanResolved
|
|
, getResolvedExecPlan
|
|
, execRemoteGQ
|
|
, getSubsOp
|
|
|
|
, EP.PlanCache
|
|
, EP.initPlanCache
|
|
, EP.clearPlanCache
|
|
, EP.dumpPlanCache
|
|
|
|
, ExecutionCtx(..)
|
|
) where
|
|
|
|
import Control.Exception (try)
|
|
import Control.Lens
|
|
import Data.Has
|
|
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Data.HashSet as Set
|
|
import qualified Data.String.Conversions as CS
|
|
import qualified Data.Text as T
|
|
import qualified Language.GraphQL.Draft.Syntax as G
|
|
import qualified Network.HTTP.Client as HTTP
|
|
import qualified Network.HTTP.Types as N
|
|
import qualified Network.Wreq as Wreq
|
|
|
|
import Hasura.EncJSON
|
|
import Hasura.GraphQL.Context
|
|
import Hasura.GraphQL.Logging
|
|
import Hasura.GraphQL.Resolve.Context
|
|
import Hasura.GraphQL.Schema
|
|
import Hasura.GraphQL.Transport.HTTP.Protocol
|
|
import Hasura.GraphQL.Validate.Types
|
|
import Hasura.HTTP
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.DDL.Headers
|
|
import Hasura.RQL.Types
|
|
import Hasura.Server.Context
|
|
import Hasura.Server.Utils (RequestId,
|
|
filterRequestHeaders)
|
|
|
|
import qualified Hasura.GraphQL.Execute.LiveQuery as EL
|
|
import qualified Hasura.GraphQL.Execute.Plan as EP
|
|
import qualified Hasura.GraphQL.Execute.Query as EQ
|
|
import qualified Hasura.GraphQL.Resolve as GR
|
|
import qualified Hasura.GraphQL.Validate as VQ
|
|
import qualified Hasura.GraphQL.Validate.Types as VT
|
|
import qualified Hasura.Logging as L
|
|
|
|
-- The current execution plan of a graphql operation, it is
|
|
-- currently, either local pg execution or a remote execution
|
|
--
|
|
-- The 'a' is parameterised so this AST can represent
|
|
-- intermediate passes
|
|
data GQExecPlan a
|
|
= GExPHasura !a
|
|
| GExPRemote !RemoteSchemaInfo !G.TypedOperationDefinition
|
|
deriving (Functor, Foldable, Traversable)
|
|
|
|
-- | Execution context
|
|
data ExecutionCtx
|
|
= ExecutionCtx
|
|
{ _ecxLogger :: !L.Logger
|
|
, _ecxSqlGenCtx :: !SQLGenCtx
|
|
, _ecxPgExecCtx :: !PGExecCtx
|
|
, _ecxPlanCache :: !EP.PlanCache
|
|
, _ecxSchemaCache :: !SchemaCache
|
|
, _ecxSchemaCacheVer :: !SchemaCacheVer
|
|
, _ecxHttpManager :: !HTTP.Manager
|
|
, _ecxEnableAllowList :: !Bool
|
|
}
|
|
|
|
-- Enforces the current limitation
|
|
assertSameLocationNodes
|
|
:: (MonadError QErr m) => [VT.TypeLoc] -> m VT.TypeLoc
|
|
assertSameLocationNodes typeLocs =
|
|
case Set.toList (Set.fromList typeLocs) of
|
|
-- this shouldn't happen
|
|
[] -> return VT.TLHasuraType
|
|
[loc] -> return loc
|
|
_ -> throw400 NotSupported msg
|
|
where
|
|
msg = "cannot mix top level fields from two different graphql servers"
|
|
|
|
-- TODO: we should fix this function asap
|
|
-- as this will fail when there is a fragment at the top level
|
|
getTopLevelNodes :: G.TypedOperationDefinition -> [G.Name]
|
|
getTopLevelNodes opDef =
|
|
mapMaybe f $ G._todSelectionSet opDef
|
|
where
|
|
f = \case
|
|
G.SelectionField fld -> Just $ G._fName fld
|
|
G.SelectionFragmentSpread _ -> Nothing
|
|
G.SelectionInlineFragment _ -> Nothing
|
|
|
|
gatherTypeLocs :: GCtx -> [G.Name] -> [VT.TypeLoc]
|
|
gatherTypeLocs gCtx nodes =
|
|
catMaybes $ flip map nodes $ \node ->
|
|
VT._fiLoc <$> Map.lookup node schemaNodes
|
|
where
|
|
schemaNodes =
|
|
let qr = VT._otiFields $ _gQueryRoot gCtx
|
|
mr = VT._otiFields <$> _gMutRoot gCtx
|
|
in maybe qr (Map.union qr) mr
|
|
|
|
-- This is for when the graphql query is validated
|
|
type ExecPlanPartial = GQExecPlan (GCtx, VQ.RootSelSet)
|
|
|
|
getExecPlanPartial
|
|
:: (MonadReusability m, MonadError QErr m)
|
|
=> UserInfo
|
|
-> SchemaCache
|
|
-> Bool
|
|
-> GQLReqParsed
|
|
-> m ExecPlanPartial
|
|
getExecPlanPartial userInfo sc enableAL req = do
|
|
|
|
-- check if query is in allowlist
|
|
when enableAL checkQueryInAllowlist
|
|
|
|
(gCtx, _) <- flip runStateT sc $ getGCtx role gCtxRoleMap
|
|
queryParts <- flip runReaderT gCtx $ VQ.getQueryParts req
|
|
|
|
let opDef = VQ.qpOpDef queryParts
|
|
topLevelNodes = getTopLevelNodes opDef
|
|
-- gather TypeLoc of topLevelNodes
|
|
typeLocs = gatherTypeLocs gCtx topLevelNodes
|
|
|
|
-- see if they are all the same
|
|
typeLoc <- assertSameLocationNodes typeLocs
|
|
|
|
case typeLoc of
|
|
VT.TLHasuraType -> do
|
|
rootSelSet <- runReaderT (VQ.validateGQ queryParts) gCtx
|
|
return $ GExPHasura (gCtx, rootSelSet)
|
|
VT.TLRemoteType _ rsi ->
|
|
return $ GExPRemote rsi opDef
|
|
where
|
|
role = userRole userInfo
|
|
gCtxRoleMap = scGCtxMap sc
|
|
|
|
checkQueryInAllowlist =
|
|
-- only for non-admin roles
|
|
when (role /= adminRole) $ do
|
|
let notInAllowlist =
|
|
not $ VQ.isQueryInAllowlist (_grQuery req) (scAllowlist sc)
|
|
when notInAllowlist $ modifyQErr modErr $ throwVE "query is not allowed"
|
|
|
|
modErr e =
|
|
let msg = "query is not in any of the allowlists"
|
|
in e{qeInternal = Just $ J.object [ "message" J..= J.String msg]}
|
|
|
|
|
|
-- An execution operation, in case of
|
|
-- queries and mutations it is just a transaction
|
|
-- to be executed
|
|
data ExecOp
|
|
= ExOpQuery !LazyRespTx !(Maybe EQ.GeneratedSqlMap)
|
|
| ExOpMutation !LazyRespTx
|
|
| ExOpSubs !EL.LiveQueryPlan
|
|
|
|
-- The graphql query is resolved into an execution operation
|
|
type ExecPlanResolved
|
|
= GQExecPlan ExecOp
|
|
|
|
getResolvedExecPlan
|
|
:: (MonadError QErr m, MonadIO m)
|
|
=> PGExecCtx
|
|
-> EP.PlanCache
|
|
-> UserInfo
|
|
-> SQLGenCtx
|
|
-> Bool
|
|
-> SchemaCache
|
|
-> SchemaCacheVer
|
|
-> GQLReqUnparsed
|
|
-> m ExecPlanResolved
|
|
getResolvedExecPlan pgExecCtx planCache userInfo sqlGenCtx
|
|
enableAL sc scVer reqUnparsed = do
|
|
planM <- liftIO $ EP.getPlan scVer (userRole userInfo)
|
|
opNameM queryStr planCache
|
|
let usrVars = userVars userInfo
|
|
case planM of
|
|
-- plans are only for queries and subscriptions
|
|
Just plan -> GExPHasura <$> case plan of
|
|
EP.RPQuery queryPlan -> do
|
|
(tx, genSql) <- EQ.queryOpFromPlan usrVars queryVars queryPlan
|
|
return $ ExOpQuery tx (Just genSql)
|
|
EP.RPSubs subsPlan ->
|
|
ExOpSubs <$> EL.reuseLiveQueryPlan pgExecCtx usrVars queryVars subsPlan
|
|
Nothing -> noExistingPlan
|
|
where
|
|
GQLReq opNameM queryStr queryVars = reqUnparsed
|
|
addPlanToCache plan =
|
|
liftIO $ EP.addPlan scVer (userRole userInfo)
|
|
opNameM queryStr plan planCache
|
|
noExistingPlan = do
|
|
req <- toParsed reqUnparsed
|
|
(partialExecPlan, queryReusability) <- runReusabilityT $
|
|
getExecPlanPartial userInfo sc enableAL req
|
|
forM partialExecPlan $ \(gCtx, rootSelSet) ->
|
|
case rootSelSet of
|
|
VQ.RMutation selSet ->
|
|
ExOpMutation <$> getMutOp gCtx sqlGenCtx userInfo selSet
|
|
VQ.RQuery selSet -> do
|
|
(queryTx, plan, genSql) <- getQueryOp gCtx sqlGenCtx userInfo queryReusability selSet
|
|
traverse_ (addPlanToCache . EP.RPQuery) plan
|
|
return $ ExOpQuery queryTx (Just genSql)
|
|
VQ.RSubscription fld -> do
|
|
(lqOp, plan) <- getSubsOp pgExecCtx gCtx sqlGenCtx userInfo queryReusability fld
|
|
traverse_ (addPlanToCache . EP.RPSubs) plan
|
|
return $ ExOpSubs lqOp
|
|
|
|
-- Monad for resolving a hasura query/mutation
|
|
type E m =
|
|
ReaderT ( UserInfo
|
|
, QueryCtxMap
|
|
, MutationCtxMap
|
|
, TypeMap
|
|
, FieldMap
|
|
, OrdByCtx
|
|
, InsCtxMap
|
|
, SQLGenCtx
|
|
) (ExceptT QErr m)
|
|
|
|
runE
|
|
:: (MonadError QErr m)
|
|
=> GCtx
|
|
-> SQLGenCtx
|
|
-> UserInfo
|
|
-> E m a
|
|
-> m a
|
|
runE ctx sqlGenCtx userInfo action = do
|
|
res <- runExceptT $ runReaderT action
|
|
(userInfo, queryCtxMap, mutationCtxMap, typeMap, fldMap, ordByCtx, insCtxMap, sqlGenCtx)
|
|
either throwError return res
|
|
where
|
|
queryCtxMap = _gQueryCtxMap ctx
|
|
mutationCtxMap = _gMutationCtxMap ctx
|
|
typeMap = _gTypes ctx
|
|
fldMap = _gFields ctx
|
|
ordByCtx = _gOrdByCtx ctx
|
|
insCtxMap = _gInsCtxMap ctx
|
|
|
|
getQueryOp
|
|
:: (MonadError QErr m)
|
|
=> GCtx
|
|
-> SQLGenCtx
|
|
-> UserInfo
|
|
-> QueryReusability
|
|
-> VQ.SelSet
|
|
-> m (LazyRespTx, Maybe EQ.ReusableQueryPlan, EQ.GeneratedSqlMap)
|
|
getQueryOp gCtx sqlGenCtx userInfo queryReusability fields =
|
|
runE gCtx sqlGenCtx userInfo $ EQ.convertQuerySelSet queryReusability fields
|
|
|
|
mutationRootName :: Text
|
|
mutationRootName = "mutation_root"
|
|
|
|
resolveMutSelSet
|
|
:: ( MonadError QErr m
|
|
, MonadReader r m
|
|
, Has UserInfo r
|
|
, Has MutationCtxMap r
|
|
, Has FieldMap r
|
|
, Has OrdByCtx r
|
|
, Has SQLGenCtx r
|
|
, Has InsCtxMap r
|
|
)
|
|
=> VQ.SelSet
|
|
-> m LazyRespTx
|
|
resolveMutSelSet fields = do
|
|
aliasedTxs <- forM (toList fields) $ \fld -> do
|
|
fldRespTx <- case VQ._fName fld of
|
|
"__typename" -> return $ return $ encJFromJValue mutationRootName
|
|
_ -> fmap liftTx . evalReusabilityT $ GR.mutFldToTx fld
|
|
return (G.unName $ G.unAlias $ VQ._fAlias fld, fldRespTx)
|
|
|
|
-- combines all transactions into a single transaction
|
|
return $ toSingleTx aliasedTxs
|
|
where
|
|
-- A list of aliased transactions for eg
|
|
-- [("f1", Tx r1), ("f2", Tx r2)]
|
|
-- are converted into a single transaction as follows
|
|
-- Tx {"f1": r1, "f2": r2}
|
|
toSingleTx :: [(Text, LazyRespTx)] -> LazyRespTx
|
|
toSingleTx aliasedTxs =
|
|
fmap encJFromAssocList $
|
|
forM aliasedTxs $ \(al, tx) -> (,) al <$> tx
|
|
|
|
getMutOp
|
|
:: (MonadError QErr m)
|
|
=> GCtx
|
|
-> SQLGenCtx
|
|
-> UserInfo
|
|
-> VQ.SelSet
|
|
-> m LazyRespTx
|
|
getMutOp ctx sqlGenCtx userInfo selSet =
|
|
runE ctx sqlGenCtx userInfo $ resolveMutSelSet selSet
|
|
|
|
getSubsOpM
|
|
:: ( MonadError QErr m
|
|
, MonadReader r m
|
|
, Has QueryCtxMap r
|
|
, Has FieldMap r
|
|
, Has OrdByCtx r
|
|
, Has SQLGenCtx r
|
|
, Has UserInfo r
|
|
, MonadIO m
|
|
)
|
|
=> PGExecCtx
|
|
-> QueryReusability
|
|
-> VQ.Field
|
|
-> m (EL.LiveQueryPlan, Maybe EL.ReusableLiveQueryPlan)
|
|
getSubsOpM pgExecCtx initialReusability fld =
|
|
case VQ._fName fld of
|
|
"__typename" ->
|
|
throwVE "you cannot create a subscription on '__typename' field"
|
|
_ -> do
|
|
(astUnresolved, finalReusability) <- runReusabilityTWith initialReusability $
|
|
GR.queryFldToPGAST fld
|
|
let varTypes = finalReusability ^? _Reusable
|
|
EL.buildLiveQueryPlan pgExecCtx (VQ._fAlias fld) astUnresolved varTypes
|
|
|
|
getSubsOp
|
|
:: ( MonadError QErr m
|
|
, MonadIO m
|
|
)
|
|
=> PGExecCtx
|
|
-> GCtx
|
|
-> SQLGenCtx
|
|
-> UserInfo
|
|
-> QueryReusability
|
|
-> VQ.Field
|
|
-> m (EL.LiveQueryPlan, Maybe EL.ReusableLiveQueryPlan)
|
|
getSubsOp pgExecCtx gCtx sqlGenCtx userInfo queryReusability fld =
|
|
runE gCtx sqlGenCtx userInfo $ getSubsOpM pgExecCtx queryReusability fld
|
|
|
|
execRemoteGQ
|
|
:: ( MonadIO m
|
|
, MonadError QErr m
|
|
, MonadReader ExecutionCtx m
|
|
)
|
|
=> RequestId
|
|
-> UserInfo
|
|
-> [N.Header]
|
|
-> GQLReqUnparsed
|
|
-> RemoteSchemaInfo
|
|
-> G.TypedOperationDefinition
|
|
-> m (HttpResponse EncJSON)
|
|
execRemoteGQ reqId userInfo reqHdrs q rsi opDef = do
|
|
execCtx <- ask
|
|
let logger = _ecxLogger execCtx
|
|
manager = _ecxHttpManager execCtx
|
|
opTy = G._todType opDef
|
|
when (opTy == G.OperationTypeSubscription) $
|
|
throw400 NotSupported "subscription to remote server is not supported"
|
|
hdrs <- getHeadersFromConf hdrConf
|
|
let confHdrs = map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) hdrs
|
|
clientHdrs = bool [] filteredHeaders fwdClientHdrs
|
|
-- filter out duplicate headers
|
|
-- priority: conf headers > resolved userinfo vars > client headers
|
|
hdrMaps = [ Map.fromList confHdrs
|
|
, Map.fromList userInfoToHdrs
|
|
, Map.fromList clientHdrs
|
|
]
|
|
headers = Map.toList $ foldr Map.union Map.empty hdrMaps
|
|
finalHeaders = addDefaultHeaders headers
|
|
initReqE <- liftIO $ try $ HTTP.parseRequest (show url)
|
|
initReq <- either httpThrow pure initReqE
|
|
let req = initReq
|
|
{ HTTP.method = "POST"
|
|
, HTTP.requestHeaders = finalHeaders
|
|
, HTTP.requestBody = HTTP.RequestBodyLBS (J.encode q)
|
|
, HTTP.responseTimeout = HTTP.responseTimeoutMicro (timeout * 1000000)
|
|
}
|
|
|
|
liftIO $ logGraphqlQuery logger $ QueryLog q Nothing reqId
|
|
res <- liftIO $ try $ HTTP.httpLbs req manager
|
|
resp <- either httpThrow return res
|
|
let cookieHdrs = getCookieHdr (resp ^.. Wreq.responseHeader "Set-Cookie")
|
|
respHdrs = Just $ mkRespHeaders cookieHdrs
|
|
return $ HttpResponse (encJFromLBS $ resp ^. Wreq.responseBody) respHdrs
|
|
|
|
where
|
|
RemoteSchemaInfo url hdrConf fwdClientHdrs timeout = rsi
|
|
httpThrow :: (MonadError QErr m) => HTTP.HttpException -> m a
|
|
httpThrow = \case
|
|
HTTP.HttpExceptionRequest _req content -> throw500 $ T.pack . show $ content
|
|
HTTP.InvalidUrlException _url reason -> throw500 $ T.pack . show $ reason
|
|
|
|
userInfoToHdrs = map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) $
|
|
userInfoToList userInfo
|
|
filteredHeaders = filterUserVars $ filterRequestHeaders reqHdrs
|
|
|
|
filterUserVars hdrs =
|
|
let txHdrs = map (\(n, v) -> (bsToTxt $ CI.original n, bsToTxt v)) hdrs
|
|
in map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) $
|
|
filter (not . isUserVar . fst) txHdrs
|
|
|
|
getCookieHdr = fmap (\h -> ("Set-Cookie", h))
|
|
|
|
mkRespHeaders hdrs =
|
|
map (\(k, v) -> Header (bsToTxt $ CI.original k, bsToTxt v)) hdrs
|