wip

tirumaraiselvan · tirumaraiselvan · commit e9fffe19babf · 2019-10-11T14:34:42.000+05:30
diff --git a/server/src-lib/Hasura/GraphQL/Execute.hs b/server/src-lib/Hasura/GraphQL/Execute.hs
@@ -1,12 +1,11 @@
 module Hasura.GraphQL.Execute
-  ( GQExecPlan(..)
-  , GQFieldExecPlan(..)
+  ( GQExecPlanPartial(..)
+  , GQFieldPartialPlan(..)
+  , GQFieldResolvedPlan(..)
 
-  , ExecPlanPartial
   , getExecPlanPartial
 
   , ExecOp(..)
-  , ExecPlanResolved
   , getResolvedExecPlan
   , execRemoteGQ
   , getSubsOp
@@ -61,12 +60,19 @@ import qualified Hasura.Logging                         as L
 --
 -- The 'a' is parameterised so this AST can represent
 -- intermediate passes
-data GQFieldExecPlan a
-  = GExPHasura !a
-  | GExPRemote !RemoteSchemaInfo !VQ.Field
-  deriving (Functor, Foldable, Traversable)
-
-type GQExecPlan a = [GQFieldExecPlan a]
+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
@@ -81,41 +87,65 @@ data ExecutionCtx
   , _ecxEnableAllowList :: !Bool
   }
 
--- This is for when the graphql query is validated
-type ExecPlanPartial = [GQFieldExecPlan (GCtx, VQ.Field)]
-
 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 remoteSchemas = scRemoteSchemas sc
   rootSelSet <- runReaderT (VQ.validateGQ queryParts) gCtx
-  generatePlan rootSelSet
+  runReaderT (generatePlan rootSelSet) (gCtx, remoteSchemas)
   where
-    generatePlan = undefined
+    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
@@ -126,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
@@ -140,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 =
@@ -303,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
@@ -330,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")
@@ -361,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
diff --git a/server/src-lib/Hasura/GraphQL/Explain.hs b/server/src-lib/Hasura/GraphQL/Explain.hs
@@ -114,21 +114,22 @@ 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 _ ->
-      throw400 InvalidParams "only queries can be explained"
-    GV.RSubscription rootField -> do
-      (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
+  undefined
+  -- E.GQExecPlanPartial opType fieldPlans <- 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 _ ->
+  --     throw400 InvalidParams "only queries can be explained"
+  --   GV.RSubscription rootField -> do
+  --     (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
diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs
@@ -2,6 +2,7 @@ module Hasura.GraphQL.Transport.HTTP
   ( runGQ
   ) where
 
+import qualified Data.Sequence                          as Seq
 import qualified Network.HTTP.Types                     as N
 
 import           Hasura.EncJSON
@@ -28,11 +29,15 @@ runGQ reqId userInfo reqHdrs req = do
   E.ExecutionCtx _ sqlGenCtx pgExecCtx planCache sc scVer _ enableAL <- ask
   fieldPlans <- E.getResolvedExecPlan pgExecCtx planCache
               userInfo sqlGenCtx enableAL sc scVer req
-  forM fieldPlans (\execPlan ->  case execPlan of
-    E.GExPHasura resolvedOp ->
+  fieldResps <- forM fieldPlans $ \case
+    E.GQFieldResolvedHasura resolvedOp ->
       flip HttpResponse Nothing <$> runHasuraGQ reqId req userInfo resolvedOp
-    E.GExPRemote rsi rootSelSet ->
-      E.execRemoteGQ reqId userInfo reqHdrs req rsi undefined)
+    E.GQFieldResolvedRemote rsi opType field ->
+      E.execRemoteGQ reqId userInfo reqHdrs rsi opType (Seq.singleton field)
+  -- pure $ mergeResponses fieldResps
+  pure $ head (toList fieldResps)
+  where
+    mergeResponses = undefined
 
 runHasuraGQ
   :: ( MonadIO m
diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs
@@ -17,6 +17,7 @@ import qualified Data.ByteString.Lazy                        as BL
 import qualified Data.CaseInsensitive                        as CI
 import qualified Data.HashMap.Strict                         as Map
 import qualified Data.IORef                                  as IORef
+import qualified Data.Sequence                               as Seq
 import qualified Data.Text                                   as T
 import qualified Data.Text.Encoding                          as TE
 import qualified Data.Time.Clock                             as TC
@@ -46,6 +47,7 @@ import           Hasura.Server.Utils                         (RequestId,
 import qualified Hasura.GraphQL.Execute                      as E
 import qualified Hasura.GraphQL.Execute.LiveQuery            as LQ
 import qualified Hasura.GraphQL.Transport.WebSocket.Server   as WS
+import qualified Hasura.GraphQL.Validate                     as VQ
 import qualified Hasura.Logging                              as L
 
 
@@ -282,11 +284,11 @@ onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
   let execCtx = E.ExecutionCtx logger sqlGenCtx pgExecCtx
                 planCache sc scVer httpMgr enableAL
 
-  case execPlan of
-    E.GExPHasura resolvedOp ->
+  forM_ execPlan $ \case
+    E.GQFieldResolvedHasura resolvedOp ->
       runHasuraGQ requestId q userInfo resolvedOp
-    E.GExPRemote rsi rootSelSet ->
-      runRemoteGQ execCtx requestId userInfo reqHdrs undefined rsi
+    E.GQFieldResolvedRemote rsi opType field ->
+      runRemoteGQ execCtx requestId userInfo reqHdrs rsi opType (Seq.singleton field)
   where
     runHasuraGQ :: RequestId -> GQLReqUnparsed -> UserInfo -> E.ExecOp
                 -> ExceptT () IO ()
@@ -313,16 +315,16 @@ onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
       sendCompleted (Just reqId)
 
     runRemoteGQ :: E.ExecutionCtx -> RequestId -> UserInfo -> [H.Header]
-                -> G.TypedOperationDefinition -> RemoteSchemaInfo
+                -> RemoteSchemaInfo -> G.OperationType -> VQ.SelSet
                 -> ExceptT () IO ()
-    runRemoteGQ execCtx reqId userInfo reqHdrs opDef rsi = do
-      when (G._todType opDef == G.OperationTypeSubscription) $
+    runRemoteGQ execCtx reqId userInfo reqHdrs rsi opType selSet = do
+      when (opType == G.OperationTypeSubscription) $
         withComplete $ preExecErr reqId $
         err400 NotSupported "subscription to remote server is not supported"
 
       -- if it's not a subscription, use HTTP to execute the query on the remote
       resp <- runExceptT $ flip runReaderT execCtx $
-              E.execRemoteGQ reqId userInfo reqHdrs q rsi opDef
+              E.execRemoteGQ reqId userInfo reqHdrs rsi opType selSet
       either (postExecErr reqId) (sendRemoteResp reqId . _hrBody) resp
       sendCompleted (Just reqId)
 
diff --git a/server/src-lib/Hasura/GraphQL/Validate/Field.hs b/server/src-lib/Hasura/GraphQL/Validate/Field.hs
