mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 12:31:52 +03:00
ec8b2c80b5
* remove phase one/two distinction and hdbquery typeclass * move extensions to default-extensions * switch to LazyTx which only acquires a connection if needed * move defns from TH module into Ops module * remove tojson orphan instance for http exception * remove orphan instance for dmlp1 * getTopLevelNodes will not throw any exceptions
142 lines
5.0 KiB
Haskell
142 lines
5.0 KiB
Haskell
module Hasura.GraphQL.Explain
|
|
( explainGQLQuery
|
|
, GQLExplain
|
|
) where
|
|
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.Aeson.Casing as J
|
|
import qualified Data.Aeson.TH as J
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Database.PG.Query as Q
|
|
import qualified Language.GraphQL.Draft.Syntax as G
|
|
import qualified Text.Builder as TB
|
|
|
|
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 Hasura.SQL.Value
|
|
|
|
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
|
|
import qualified Hasura.SQL.DML as S
|
|
|
|
data GQLExplain
|
|
= GQLExplain
|
|
{ _gqeQuery :: !GH.GraphQLRequest
|
|
, _gqeUser :: !(Maybe (Map.HashMap Text Text))
|
|
} deriving (Show, Eq)
|
|
|
|
$(J.deriveJSON (J.aesonDrop 4 J.camelCase){J.omitNothingFields=True}
|
|
''GQLExplain
|
|
)
|
|
|
|
data FieldPlan
|
|
= FieldPlan
|
|
{ _fpField :: !G.Name
|
|
, _fpSql :: !(Maybe Text)
|
|
, _fpPlan :: !(Maybe [Text])
|
|
} deriving (Show, Eq)
|
|
|
|
$(J.deriveJSON (J.aesonDrop 3 J.camelCase) ''FieldPlan)
|
|
|
|
type Explain =
|
|
(ReaderT (FieldMap, OrdByCtx) (Except QErr))
|
|
|
|
runExplain
|
|
:: (MonadError QErr m)
|
|
=> (FieldMap, OrdByCtx) -> Explain a -> m a
|
|
runExplain ctx m =
|
|
either throwError return $ runExcept $ runReaderT m ctx
|
|
|
|
explainField
|
|
:: (MonadTx m)
|
|
=> UserInfo -> GCtx -> Field -> m FieldPlan
|
|
explainField userInfo gCtx fld =
|
|
case fName of
|
|
"__type" -> return $ FieldPlan fName Nothing Nothing
|
|
"__schema" -> return $ FieldPlan fName Nothing Nothing
|
|
"__typename" -> return $ FieldPlan fName Nothing Nothing
|
|
_ -> do
|
|
opCxt <- getOpCtx fName
|
|
sel <- runExplain (fldMap, orderByCtx) $ case opCxt of
|
|
OCSelect tn permFilter permLimit hdrs -> do
|
|
validateHdrs hdrs
|
|
RS.mkSQLSelect False <$>
|
|
RS.fromField txtConverter tn permFilter permLimit fld
|
|
OCSelectPkey tn permFilter hdrs -> do
|
|
validateHdrs hdrs
|
|
RS.mkSQLSelect True <$>
|
|
RS.fromFieldByPKey txtConverter tn permFilter fld
|
|
OCSelectAgg tn permFilter permLimit hdrs -> do
|
|
validateHdrs hdrs
|
|
RS.mkAggSelect <$>
|
|
RS.fromAggField txtConverter tn permFilter permLimit fld
|
|
_ -> throw500 "unexpected mut field info for explain"
|
|
|
|
let selectSQL = TB.run $ toSQL sel
|
|
withExplain = "EXPLAIN (FORMAT TEXT) " <> selectSQL
|
|
planLines <- liftTx $ map runIdentity <$>
|
|
Q.listQE dmlTxErrorHandler (Q.fromText withExplain) () True
|
|
return $ FieldPlan fName (Just selectSQL) $ Just planLines
|
|
where
|
|
fName = _fName fld
|
|
txtConverter (ty, val) =
|
|
return $ S.annotateExp (txtEncoder val) ty
|
|
opCtxMap = _gOpCtxMap gCtx
|
|
fldMap = _gFields gCtx
|
|
orderByCtx = _gOrdByCtx gCtx
|
|
|
|
getOpCtx f =
|
|
onNothing (Map.lookup f opCtxMap) $ throw500 $
|
|
"lookup failed: opctx: " <> showName f
|
|
|
|
validateHdrs hdrs = do
|
|
let receivedHdrs = userVars userInfo
|
|
forM_ hdrs $ \hdr ->
|
|
unless (isJust $ getVarVal hdr receivedHdrs) $
|
|
throw400 NotFound $ hdr <<> " header is expected but not found"
|
|
|
|
explainGQLQuery
|
|
:: (MonadError QErr m, MonadIO m)
|
|
=> Q.PGPool
|
|
-> Q.TxIsolation
|
|
-> SchemaCache
|
|
-> GQLExplain
|
|
-> m BL.ByteString
|
|
explainGQLQuery pool iso sc (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) (toList selSet)
|
|
plans <- liftIO (runExceptT $ runTx tx) >>= liftEither
|
|
return $ J.encode plans
|
|
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
|