这是indexloc提供的服务,不要输入任何密码
Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 2 additions & 1 deletion server/graphql-engine.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -208,8 +208,9 @@ library
, Hasura.GraphQL.Validate.Context
, Hasura.GraphQL.Validate.Field
, Hasura.GraphQL.Validate.InputValue
, Hasura.GraphQL.Resolve
, Hasura.GraphQL.Explain
, Hasura.GraphQL.Execute
, Hasura.GraphQL.Resolve
, Hasura.GraphQL.Resolve.LiveQuery
, Hasura.GraphQL.Resolve.BoolExp
, Hasura.GraphQL.Resolve.Context
Expand Down
130 changes: 130 additions & 0 deletions server/src-lib/Hasura/GraphQL/Execute.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,130 @@
module Hasura.GraphQL.Execute
( GQExecPlan(..)
, getExecPlan
, execRemoteGQ
) where

import Control.Exception (try)
import Control.Lens

import qualified Data.ByteString.Lazy as BL
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.Schema
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.HTTP
import Hasura.Prelude
import Hasura.RQL.DDL.Headers
import Hasura.RQL.Types

import qualified Hasura.GraphQL.Validate as VQ
import qualified Hasura.GraphQL.Validate.Types as VT

data GQExecPlan
= GExPHasura !GCtx !VQ.RootSelSet
| GExPRemote !RemoteSchemaInfo !G.TypedOperationDefinition

getExecPlan
:: (MonadError QErr m)
=> UserInfo
-> SchemaCache
-> GraphQLRequest
-> m GQExecPlan
getExecPlan userInfo sc req = do

(gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) 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.HasuraType ->
GExPHasura gCtx <$> runReaderT (VQ.validateGQ queryParts) gCtx
VT.RemoteType _ rsi ->
return $ GExPRemote rsi opDef
where
gCtxRoleMap = scGCtxMap sc

execRemoteGQ
:: (MonadIO m, MonadError QErr m)
=> HTTP.Manager
-> UserInfo
-> [N.Header]
-> BL.ByteString
-- ^ the raw request string
-> RemoteSchemaInfo
-> G.TypedOperationDefinition
-> m EncJSON
execRemoteGQ manager userInfo reqHdrs q rsi opDef = do
let 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
options = wreqOptions manager (userInfoToHdrs ++ clientHdrs ++ confHdrs)

res <- liftIO $ try $ Wreq.postWith options (show url) q
resp <- either httpThrow return res
return $ encJFromLBS $ resp ^. Wreq.responseBody

where
RemoteSchemaInfo url hdrConf fwdClientHdrs = rsi
httpThrow :: (MonadError QErr m) => HTTP.HttpException -> m a
httpThrow err = throw500 $ T.pack . show $ err

userInfoToHdrs = map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) $
userInfoToList userInfo
filteredHeaders = flip filter reqHdrs $ \(n, _) ->
n `notElem` [ "Content-Length", "Content-MD5", "User-Agent", "Host"
, "Origin", "Referer" , "Accept", "Accept-Encoding"
, "Accept-Language", "Accept-Datetime"
, "Cache-Control", "Connection", "DNT"
]

assertSameLocationNodes
:: (MonadError QErr m) => [VT.TypeLoc] -> m VT.TypeLoc
assertSameLocationNodes typeLocs =
case Set.toList (Set.fromList typeLocs) of
-- this shouldn't happen
[] -> return VT.HasuraType
[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
43 changes: 17 additions & 26 deletions server/src-lib/Hasura/GraphQL/Explain.hs
Original file line number Diff line number Diff line change
Expand Up @@ -13,21 +13,19 @@ import qualified Database.PG.Query as Q
import qualified Language.GraphQL.Draft.Syntax as G
import qualified Text.Builder as TB

import Hasura.GraphQL.Context
import Hasura.EncJSON
import Hasura.GraphQL.Context
import Hasura.GraphQL.Resolve.Context
import Hasura.GraphQL.Schema
import Hasura.GraphQL.Validate.Field
import Hasura.Prelude
import Hasura.RQL.DML.Internal
import Hasura.RQL.Types
import Hasura.SQL.Types

import qualified Hasura.GraphQL.Execute as E
import qualified Hasura.GraphQL.Resolve.Select as RS
import qualified Hasura.GraphQL.Transport.HTTP as TH
import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
import qualified Hasura.GraphQL.Validate as GV
import qualified Hasura.GraphQL.Validate.Types as VT
import qualified Hasura.RQL.DML.Select as RS

data GQLExplain
Expand Down Expand Up @@ -128,30 +126,23 @@ explainGQLQuery
-> GQLExplain
-> m EncJSON
explainGQLQuery pool iso sc sqlGenCtx (GQLExplain query userVarsRaw)= do
(gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) gCtxMap
queryParts <- runReaderT (GV.getQueryParts query) gCtx
let topLevelNodes = TH.getTopLevelNodes (GV.qpOpDef queryParts)

unless (allHasuraNodes gCtx topLevelNodes) $
throw400 InvalidParams "only hasura queries can be explained"

(opTy, selSet) <- runReaderT (GV.validateGQ queryParts) gCtx
unless (opTy == G.OperationTypeQuery) $
throw400 InvalidParams "only queries can be explained"
let tx = mapM (explainField userInfo gCtx sqlGenCtx) (toList selSet)
plans <- liftIO (runExceptT $ runTx tx) >>= liftEither
return $ encJFromJValue plans

execPlan <- E.getExecPlan userInfo sc query
(gCtx, rootSelSet) <- case execPlan of
E.GExPHasura gCtx rootSelSet ->
return (gCtx, rootSelSet)
E.GExPRemote _ _ ->
throw400 InvalidParams "only hasura queries can be explained"
case rootSelSet of
GV.RQuery selSet -> do
let tx = mapM (explainField userInfo gCtx sqlGenCtx) (toList selSet)
plans <- liftIO (runExceptT $ runTx tx) >>= liftEither
return $ encJFromJValue plans
GV.RMutation _ ->
throw400 InvalidParams "only queries can be explained"
GV.RSubscription _ ->
throw400 InvalidParams "only queries can be explained"
where
gCtxMap = scGCtxMap sc
usrVars = mkUserVars $ maybe [] Map.toList userVarsRaw
userInfo = mkUserInfo (fromMaybe adminRole $ roleFromVars usrVars) usrVars

runTx tx = runLazyTx pool iso $ withUserInfo userInfo tx

allHasuraNodes gCtx nodes =
let typeLocs = TH.gatherTypeLocs gCtx nodes
isHasuraNode = \case
VT.HasuraType -> True
VT.RemoteType _ _ -> False
in all isHasuraNode typeLocs
149 changes: 87 additions & 62 deletions server/src-lib/Hasura/GraphQL/Resolve.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,7 @@
module Hasura.GraphQL.Resolve
( resolveSelSet
( resolveQuerySelSet
, resolveMutSelSet
, resolveSubsFld
) where

import Hasura.Prelude
Expand All @@ -8,8 +10,8 @@ import qualified Data.HashMap.Strict as Map
import qualified Database.PG.Query as Q
import qualified Language.GraphQL.Draft.Syntax as G

import Hasura.GraphQL.Context
import Hasura.EncJSON
import Hasura.GraphQL.Context
import Hasura.GraphQL.Resolve.Context
import Hasura.GraphQL.Resolve.Introspect
import Hasura.GraphQL.Validate.Field
Expand All @@ -20,83 +22,106 @@ import qualified Hasura.GraphQL.Resolve.Insert as RI
import qualified Hasura.GraphQL.Resolve.Mutation as RM
import qualified Hasura.GraphQL.Resolve.Select as RS

-- {-# SCC buildTx #-}
buildTx :: UserInfo -> GCtx -> SQLGenCtx -> Field -> Q.TxE QErr EncJSON
buildTx userInfo gCtx sqlCtx fld = do
validateHdrs
:: (Foldable t, QErrM m) => UserInfo -> t Text -> m ()
validateHdrs userInfo hdrs = do
let receivedVars = userVars userInfo
forM_ hdrs $ \hdr ->
unless (isJust $ getVarVal hdr receivedVars) $
throw400 NotFound $ hdr <<> " header is expected but not found"

resolvePGFld
:: UserInfo
-> GCtx
-> SQLGenCtx
-> Field
-> Q.TxE QErr EncJSON
resolvePGFld userInfo gCtx sqlCtx fld = do
opCxt <- getOpCtx $ _fName fld
join $ fmap fst $ runConvert ( fldMap
, orderByCtx
, insCtxMap
, sqlCtx
) $ case opCxt of

OCSelect ctx ->
validateHdrs (_socHeaders ctx) >> RS.convertSelect ctx fld

OCSelectPkey ctx ->
validateHdrs (_spocHeaders ctx) >> RS.convertSelectByPKey ctx fld

OCSelectAgg ctx ->
validateHdrs (_socHeaders ctx) >> RS.convertAggSelect ctx fld

OCFuncQuery ctx ->
validateHdrs (_fqocHeaders ctx) >> RS.convertFuncQuery ctx False fld

OCFuncAggQuery ctx ->
validateHdrs (_fqocHeaders ctx) >> RS.convertFuncQuery ctx True fld

OCInsert ctx ->
validateHdrs (_iocHeaders ctx) >> RI.convertInsert roleName (_iocTable ctx) fld

OCUpdate ctx ->
validateHdrs (_uocHeaders ctx) >> RM.convertUpdate ctx fld

OCDelete ctx ->
validateHdrs (_docHeaders ctx) >> RM.convertDelete ctx fld
join $ runConvert (fldMap, orderByCtx, insCtxMap, sqlCtx) $ case opCxt of
OCSelect ctx -> do
validateHdrs userInfo (_socHeaders ctx)
RS.convertSelect ctx fld
OCSelectPkey ctx -> do
validateHdrs userInfo (_spocHeaders ctx)
RS.convertSelectByPKey ctx fld
OCSelectAgg ctx -> do
validateHdrs userInfo (_socHeaders ctx)
RS.convertAggSelect ctx fld
OCFuncQuery ctx -> do
validateHdrs userInfo (_fqocHeaders ctx)
RS.convertFuncQuery ctx False fld
OCFuncAggQuery ctx -> do
validateHdrs userInfo (_fqocHeaders ctx)
RS.convertFuncQuery ctx True fld
OCInsert ctx -> do
validateHdrs userInfo (_iocHeaders ctx)
RI.convertInsert roleName (_iocTable ctx) fld
OCUpdate ctx -> do
validateHdrs userInfo (_uocHeaders ctx)
RM.convertUpdate ctx fld
OCDelete ctx -> do
validateHdrs userInfo (_docHeaders ctx)
RM.convertDelete ctx fld
where
roleName = userRole userInfo
opCtxMap = _gOpCtxMap gCtx
fldMap = _gFields gCtx
orderByCtx = _gOrdByCtx gCtx
insCtxMap = _gInsCtxMap gCtx
roleName = userRole userInfo

getOpCtx f =
onNothing (Map.lookup f opCtxMap) $ throw500 $
"lookup failed: opctx: " <> showName f

validateHdrs hdrs = do
let receivedVars = userVars userInfo
forM_ hdrs $ \hdr ->
unless (isJust $ getVarVal hdr receivedVars) $
throw400 NotFound $ hdr <<> " header is expected but not found"
mkRootTypeName :: G.OperationType -> Text
mkRootTypeName = \case
G.OperationTypeQuery -> "query_root"
G.OperationTypeMutation -> "mutation_root"
G.OperationTypeSubscription -> "subscription_root"

-- {-# SCC resolveFld #-}
resolveFld
resolveQuerySelSet
:: (MonadTx m)
=> UserInfo -> GCtx -> SQLGenCtx
-> G.OperationType
-> Field
=> UserInfo
-> GCtx
-> SQLGenCtx
-> SelSet
-> m EncJSON
resolveFld userInfo gCtx sqlGenCtx opTy fld =
case _fName fld of
"__type" -> encJFromJValue <$> runReaderT (typeR fld) gCtx
"__schema" -> encJFromJValue <$> runReaderT (schemaR fld) gCtx
"__typename" -> return $ encJFromJValue $ mkRootTypeName opTy
_ -> liftTx $ buildTx userInfo gCtx sqlGenCtx fld
where
mkRootTypeName :: G.OperationType -> Text
mkRootTypeName = \case
G.OperationTypeQuery -> "query_root"
G.OperationTypeMutation -> "mutation_root"
G.OperationTypeSubscription -> "subscription_root"
resolveQuerySelSet userInfo gCtx sqlGenCtx fields =
fmap encJFromAssocList $ forM (toList fields) $ \fld -> do
fldResp <- case _fName fld of
"__type" -> encJFromJValue <$> runReaderT (typeR fld) gCtx
"__schema" -> encJFromJValue <$> runReaderT (schemaR fld) gCtx
"__typename" -> return $ encJFromJValue $
mkRootTypeName G.OperationTypeQuery
_ -> liftTx $ resolvePGFld userInfo gCtx sqlGenCtx fld
return (G.unName $ G.unAlias $ _fAlias fld, fldResp)

resolveSelSet
resolveMutSelSet
:: (MonadTx m)
=> UserInfo -> GCtx -> SQLGenCtx
-> G.OperationType
=> UserInfo
-> GCtx
-> SQLGenCtx
-> SelSet
-> m EncJSON
resolveSelSet userInfo gCtx sqlGenCtx opTy fields =
resolveMutSelSet userInfo gCtx sqlGenCtx fields =
fmap encJFromAssocList $ forM (toList fields) $ \fld -> do
fldResp <- resolveFld userInfo gCtx sqlGenCtx opTy fld
fldResp <- case _fName fld of
"__typename" -> return $ encJFromJValue $
mkRootTypeName G.OperationTypeMutation
_ -> liftTx $ resolvePGFld userInfo gCtx sqlGenCtx fld
return (G.unName $ G.unAlias $ _fAlias fld, fldResp)

resolveSubsFld
:: (MonadTx m)
=> UserInfo
-> GCtx
-> SQLGenCtx
-> Field
-> m EncJSON
resolveSubsFld userInfo gCtx sqlGenCtx fld = do
resp <- case _fName fld of
"__typename" -> return $ encJFromJValue $
mkRootTypeName G.OperationTypeSubscription
_ -> liftTx $ resolvePGFld userInfo gCtx sqlGenCtx fld
return $ encJFromAssocList [(G.unName $ G.unAlias $ _fAlias fld, resp)]
Loading