Mock exec plan 2

server/src-lib/Hasura/GraphQL/Execute.hs

@@ -1,11 +1,11 @@
 module Hasura.GraphQL.Execute
-  ( GQExecPlan(..)
+  ( GQExecPlanPartial(..)
+  , GQFieldPartialPlan(..)
+  , GQFieldResolvedPlan(..)
 
-  , ExecPlanPartial
   , getExecPlanPartial
 
   , ExecOp(..)
-  , ExecPlanResolved
   , getResolvedExecPlan
   , execRemoteGQ
   , getSubsOp
@@ -25,7 +25,7 @@ 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.Sequence                          as Seq
 import qualified Data.String.Conversions                as CS
 import qualified Data.Text                              as T
 import qualified Language.GraphQL.Draft.Syntax          as G
@@ -53,18 +53,26 @@ 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)
+data GQFieldPartialPlan
+  = GQFieldPartialHasura !(GCtx, VQ.Field)
+  | GQFieldPartialRemote !RemoteSchemaInfo !VQ.Field
+
+data GQFieldResolvedPlan
+  = GQFieldResolvedHasura !ExecOp
+  | GQFieldResolvedRemote !RemoteSchemaInfo !G.OperationType !VQ.Field
+
+data GQExecPlanPartial
+  = GQExecPlanPartial
+  { execOpType     :: G.OperationType
+  , execFieldPlans :: Seq.Seq GQFieldPartialPlan
+  }
 
 -- | Execution context
 data ExecutionCtx
@@ -79,85 +87,65 @@ data ExecutionCtx
   , _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
   :: (MonadError QErr m)
   => UserInfo
   -> SchemaCache
   -> Bool
   -> GQLReqParsed
-  -> m ExecPlanPartial
-getExecPlanPartial userInfo sc enableAL req = do
-
+  -> m GQExecPlanPartial
+getExecPlanPartial userInfo sc enableAL req
   -- check if query is in allowlist
+ = do
   when enableAL checkQueryInAllowlist
-
-  (gCtx, _)  <- flip runStateT sc $ getGCtx role gCtxRoleMap
+  (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
+  let remoteSchemas = scRemoteSchemas sc
+  rootSelSet <- runReaderT (VQ.validateGQ queryParts) gCtx
+  runReaderT (generatePlan rootSelSet) (gCtx, remoteSchemas)
   where
+    generatePlan ::
+         (MonadError QErr m, MonadReader (GCtx, RemoteSchemaMap) m)
+      => VQ.RootSelSet
+      -> m GQExecPlanPartial
+    generatePlan =
+      \case
+        VQ.RQuery selSet ->
+          (GQExecPlanPartial G.OperationTypeQuery) <$>
+          (mapM generateFieldPlan selSet)
+        VQ.RMutation selSet ->
+          (GQExecPlanPartial G.OperationTypeMutation) <$>
+          (mapM generateFieldPlan selSet)
+        VQ.RSubscription field ->
+          (GQExecPlanPartial G.OperationTypeMutation) <$>
+          (mapM generateFieldPlan (Seq.singleton field))
+    generateFieldPlan ::
+         (MonadError QErr m, MonadReader (GCtx, RemoteSchemaMap) m)
+      => VQ.Field
+      -> m GQFieldPartialPlan
+    generateFieldPlan field =
+      case VQ._fSource field of
+        TLHasuraType -> do
+          (gCtx, _) <- ask
+          pure $ GQFieldPartialHasura (gCtx, field)
+        TLRemoteType rsName -> do
+          (_, rsMap) <- ask
+          rsCtx <-
+            onNothing (Map.lookup rsName rsMap) $
+            throw500 "remote schema not found"
+          pure $ GQFieldPartialRemote (rscInfo rsCtx) field
     role = userRole userInfo
     gCtxRoleMap = scGCtxMap sc
-
-    checkQueryInAllowlist =
+    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]}
+       in e {qeInternal = Just $ J.object ["message" J..= J.String msg]}
 
 
 -- An execution operation, in case of
@@ -168,10 +156,6 @@ data ExecOp
   | 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
@@ -182,41 +166,63 @@ getResolvedExecPlan
   -> 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
+  -> m (Seq.Seq GQFieldResolvedPlan)
+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
+  case planM
     -- 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
+        of
+    Just plan ->
+      case plan of
+        EP.RPQuery queryPlan -> do
+          (tx, genSql) <- EQ.queryOpFromPlan usrVars queryVars queryPlan
+          let queryOp = ExOpQuery tx (Just genSql)
+          pure $ pure $ GQFieldResolvedHasura queryOp
+        EP.RPSubs subsPlan -> do
+          subOp <-
+            ExOpSubs <$>
+            EL.reuseLiveQueryPlan pgExecCtx usrVars queryVars subsPlan
+          pure $ pure $ GQFieldResolvedHasura subOp
     Nothing -> noExistingPlan
   where
     GQLReq opNameM queryStr queryVars = reqUnparsed
     addPlanToCache plan =
-      liftIO $ EP.addPlan scVer (userRole userInfo)
-      opNameM queryStr plan planCache
+      liftIO $
+      EP.addPlan scVer (userRole userInfo) opNameM queryStr plan planCache
     noExistingPlan = do
       req <- toParsed reqUnparsed
-      partialExecPlan <- 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 selSet
-            traverse_ (addPlanToCache . EP.RPQuery) plan
-            return $ ExOpQuery queryTx (Just genSql)
-          VQ.RSubscription fld -> do
-            (lqOp, plan) <- getSubsOp pgExecCtx gCtx sqlGenCtx userInfo fld
-            traverse_ (addPlanToCache . EP.RPSubs) plan
-            return $ ExOpSubs lqOp
+      (GQExecPlanPartial opType fieldPlans) <-
+        getExecPlanPartial userInfo sc enableAL req
+      case opType of
+        G.OperationTypeQuery ->
+          forM fieldPlans $ \case
+            GQFieldPartialHasura (gCtx, field) -> do
+              (queryTx, plan, genSql) <-
+                getQueryOp gCtx sqlGenCtx userInfo (Seq.singleton field)
+              traverse_ (addPlanToCache . EP.RPQuery) plan
+              (return . GQFieldResolvedHasura) $ ExOpQuery queryTx (Just genSql)
+            GQFieldPartialRemote rsInfo field ->
+              return $ GQFieldResolvedRemote rsInfo G.OperationTypeQuery field
+        G.OperationTypeMutation ->
+          forM fieldPlans $ \case
+            GQFieldPartialHasura (gCtx, field) -> do
+              mutationTx <-
+                getMutOp gCtx sqlGenCtx userInfo (Seq.singleton field)
+              (return . GQFieldResolvedHasura) $ ExOpMutation mutationTx
+            GQFieldPartialRemote rsInfo field ->
+              return $
+              GQFieldResolvedRemote rsInfo G.OperationTypeMutation field
+        G.OperationTypeSubscription ->
+          forM fieldPlans $ \case
+            GQFieldPartialHasura (gCtx, field) -> do
+              (lqOp, plan) <- getSubsOp pgExecCtx gCtx sqlGenCtx userInfo field
+              traverse_ (addPlanToCache . EP.RPSubs) plan
+              (return . GQFieldResolvedHasura) $ ExOpSubs lqOp
+            GQFieldPartialRemote rsInfo field ->
+              return $
+              GQFieldResolvedRemote rsInfo G.OperationTypeSubscription field
 
 -- Monad for resolving a hasura query/mutation
 type E m =
@@ -345,18 +351,19 @@ execRemoteGQ
   => RequestId
   -> UserInfo
   -> [N.Header]
-  -> GQLReqUnparsed
   -> RemoteSchemaInfo
-  -> G.TypedOperationDefinition
+  -> G.OperationType
+  -> VQ.SelSet
   -> m (HttpResponse EncJSON)
-execRemoteGQ reqId userInfo reqHdrs q rsi opDef = do
+execRemoteGQ reqId userInfo reqHdrs rsi opType selSet = do
   execCtx <- ask
   let logger  = _ecxLogger execCtx
       manager = _ecxHttpManager execCtx
-      opTy    = G._todType opDef
-  when (opTy == G.OperationTypeSubscription) $
+  when (opType == G.OperationTypeSubscription) $
     throw400 NotSupported "subscription to remote server is not supported"
   hdrs <- getHeadersFromConf hdrConf
+  gqlReq <- fieldsToRequest opType selSet
+  let body = encJToLBS (encJFromJValue gqlReq)
   let confHdrs   = map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) hdrs
       clientHdrs = bool [] filteredHeaders fwdClientHdrs
       -- filter out duplicate headers
@@ -372,11 +379,11 @@ execRemoteGQ reqId userInfo reqHdrs q rsi opDef = do
   let req = initReq
            { HTTP.method = "POST"
            , HTTP.requestHeaders = finalHeaders
-           , HTTP.requestBody = HTTP.RequestBodyLBS (J.encode q)
+           , HTTP.requestBody = HTTP.RequestBodyLBS body
            , HTTP.responseTimeout = HTTP.responseTimeoutMicro (timeout * 1000000)
            }
 
-  liftIO $ logGraphqlQuery logger $ QueryLog q Nothing reqId
+  -- 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")
@@ -403,3 +410,11 @@ execRemoteGQ reqId userInfo reqHdrs q rsi opDef = do
 
     mkRespHeaders hdrs =
       map (\(k, v) -> Header (bsToTxt $ CI.original k, bsToTxt v)) hdrs
+
+
+fieldsToRequest
+  :: (MonadIO m, MonadError QErr m)
+  => G.OperationType
+  -> Seq.Seq VQ.Field
+  -> m GQLReqParsed
+fieldsToRequest = undefined

server/src-lib/Hasura/GraphQL/Explain.hs

@@ -114,21 +114,36 @@ explainGQLQuery
   -> GQLExplain
   -> m EncJSON
 explainGQLQuery pgExecCtx sc sqlGenCtx enableAL (GQLExplain query userVarsRaw) = do
-  execPlan <- E.getExecPlanPartial userInfo sc enableAL 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 ->
-      runInTx $ encJFromJValue <$> traverse (explainField userInfo gCtx sqlGenCtx) (toList selSet)
-    GV.RMutation _ ->
+  E.GQExecPlanPartial opType fieldPlans <-
+    E.getExecPlanPartial userInfo sc enableAL query
+  let hasuraFieldPlans = mapMaybe getHasuraField (toList fieldPlans)
+  if null hasuraFieldPlans
+    then throw400 InvalidParams "only hasura queries can be explained"
+    else pure ()
+  case opType of
+    G.OperationTypeQuery ->
+      runInTx $
+      encJFromJValue <$>
+      traverse
+        (\(gCtx, field) -> explainField userInfo gCtx sqlGenCtx field)
+        hasuraFieldPlans
+    G.OperationTypeMutation ->
       throw400 InvalidParams "only queries can be explained"
-    GV.RSubscription rootField -> do
+    G.OperationTypeSubscription -> do
+      (gCtx, rootField) <- getRootField hasuraFieldPlans
       (plan, _) <- E.getSubsOp pgExecCtx gCtx sqlGenCtx userInfo rootField
       runInTx $ encJFromJValue <$> E.explainLiveQueryPlan plan
   where
     usrVars = mkUserVars $ maybe [] Map.toList userVarsRaw
     userInfo = mkUserInfo (fromMaybe adminRole $ roleFromVars usrVars) usrVars
     runInTx = liftEither <=< liftIO . runExceptT . runLazyTx pgExecCtx
+    getHasuraField =
+      \case
+        E.GQFieldPartialHasura a -> Just a
+        _ -> Nothing
+    getRootField =
+      \case
+        [] -> throw400 InvalidParams "no field found in subscription"
+        [fld] -> pure fld
+        _ ->
+          throw400 InvalidParams "expected only one top field in subscription"

server/src-lib/Hasura/GraphQL/RemoteServer.hs

@@ -63,7 +63,7 @@ fetchRemoteSchema manager name def@(RemoteSchemaInfo url headerConf _ timeout) =
   let (sDoc, qRootN, mRootN, sRootN) =
         fromIntrospection introspectRes
   typMap <- either remoteSchemaErr return $ VT.fromSchemaDoc sDoc $
-     VT.TLRemoteType name def
+     VT.TLRemoteType name
   let mQrTyp = Map.lookup qRootN typMap
       mMrTyp = maybe Nothing (`Map.lookup` typMap) mRootN
       mSrTyp = maybe Nothing (`Map.lookup` typMap) sRootN