hasura · 0x777 · Jul 15, 2020 · Jul 14, 2020 · Jul 14, 2020 · Jul 15, 2020
@@ -212,6 +212,10 @@ library
 
                      , directory
 
+                     , random
+                     , mmorph
+                     , http-api-data
+
                      , semigroups >= 0.19.1
 
                      -- scheduled triggers
@@ -405,6 +409,7 @@ library
                      , Hasura.SQL.Time
                      , Hasura.SQL.Types
                      , Hasura.SQL.Value
+                     , Hasura.Tracing
                      , Network.URI.Extended
                      , Network.Wai.Extended
                      , Network.Wai.Handler.WebSockets.Custom

@@ -20,6 +20,7 @@ import qualified Data.ByteString.Lazy       as BL
 import qualified Data.ByteString.Lazy.Char8 as BLC
 import qualified Data.Environment           as Env
 import qualified Database.PG.Query          as Q
+import qualified Hasura.Tracing             as Tracing
 import qualified System.Exit                as Sys
 import qualified System.Posix.Signals       as Signals
 
@@ -67,7 +68,8 @@ runApp env (HGEOptionsG rci hgeCmd) =
       let sqlGenCtx = SQLGenCtx False
       res <- runAsAdmin _icPgPool sqlGenCtx _icHttpManager $ do
         schemaCache <- buildRebuildableSchemaCache env
-        execQuery env queryBs
+        execQuery env queryBs 
+          & Tracing.runTraceTWithReporter Tracing.noReporter "execute"
           & runHasSystemDefinedT (SystemDefined False)
           & runCacheRWT schemaCache
           & fmap (\(res, _, _) -> res)

@@ -7,6 +7,7 @@ import           Control.Exception                         (throwIO)
 import           Control.Lens                              (view, _2)
 import           Control.Monad.Base
 import           Control.Monad.Catch                       (MonadCatch, MonadMask, MonadThrow, onException, Exception)
+import           Control.Monad.Morph                       (hoist)
 import           Control.Monad.Stateless
 import           Control.Monad.STM                         (atomically)
 import           Control.Monad.Trans.Control               (MonadBaseControl (..))
@@ -36,6 +37,7 @@ import qualified System.Log.FastLogger                     as FL
 import qualified Text.Mustache.Compile                     as M
 import qualified Control.Immortal                          as Immortal
 
+import           Hasura.GraphQL.Transport.HTTP             (MonadExecuteQuery(..))
 import           Hasura.Db
 import           Hasura.EncJSON
 import           Hasura.Eventing.EventTrigger
@@ -69,6 +71,7 @@ import           Hasura.Server.Telemetry
 import           Hasura.Server.Version
 import           Hasura.Session
 
+import qualified Hasura.Tracing                            as Tracing
 import qualified Hasura.GraphQL.Transport.WebSocket.Server as WS
 
 data ExitCode
@@ -281,14 +284,16 @@ runHGEServer
      , MonadMask m
      , MonadStateless IO m
      , LA.Forall (LA.Pure m)
-     , UserAuthentication m
+     , UserAuthentication (Tracing.TraceT m)
      , HttpLog m
      , ConsoleRenderer m
      , MetadataApiAuthorization m
      , MonadGQLExecutionCheck m
      , MonadConfigApiHandler m
      , MonadQueryLog m
      , WS.MonadWSLog m
+     , MonadExecuteQuery m
+     , Tracing.HasReporter m
      )
   => Env.Environment
   -> ServeOptions impl
@@ -581,6 +586,7 @@ execQuery
      , HasSQLGenCtx m
      , UserInfoM m
      , HasSystemDefined m
+     , Tracing.MonadTrace m
      )
   => Env.Environment
   -> BLC.ByteString
@@ -592,6 +598,8 @@ execQuery env queryBs = do
   buildSchemaCacheStrict
   encJToLBS <$> runQueryM env query
 
+instance Tracing.HasReporter AppM
+
 instance HttpLog AppM where
   logHttpError logger userInfoM reqId httpReq req qErr headers =
     unLogger logger $ mkHttpLog $
@@ -601,7 +609,11 @@ instance HttpLog AppM where
     unLogger logger $ mkHttpLog $
       mkHttpAccessLogContext userInfoM reqId httpReq compressedResponse qTime cType headers
 
-instance UserAuthentication AppM where
+instance MonadExecuteQuery AppM where
+  executeQuery _ _ _ pgCtx _txAccess tx =
+    ([],) <$> hoist (runQueryTx pgCtx) tx
+
+instance UserAuthentication (Tracing.TraceT AppM) where
   resolveUserInfo logger manager headers authMode =
     runExceptT $ getUserInfoWithExpTime logger manager headers authMode
 

@@ -38,6 +38,7 @@ import           Hasura.SQL.Error
 import           Hasura.SQL.Types
 
 import qualified Hasura.SQL.DML               as S
+import qualified Hasura.Tracing               as Tracing
 
 data PGExecCtx
   = PGExecCtx
@@ -81,6 +82,8 @@ instance (Monoid w, MonadTx m) => MonadTx (WriterT w m) where
   liftTx = lift . liftTx
 instance (MonadTx m) => MonadTx (ValidateT e m) where
   liftTx = lift . liftTx
+instance (MonadTx m) => MonadTx (Tracing.TraceT m) where
+  liftTx = lift . liftTx
 
 -- | Like 'Q.TxE', but defers acquiring a Postgres connection until the first
 -- execution of 'liftTx'.  If no call to 'liftTx' is ever reached (i.e. a

@@ -61,6 +61,7 @@ import           Hasura.RQL.DDL.Headers
 import           Hasura.RQL.Types
 import           Hasura.Server.Version                (HasVersion)
 import           Hasura.SQL.Types
+import qualified Hasura.Tracing                       as Tracing
 
 import qualified Control.Concurrent.Async.Lifted.Safe as LA
 import qualified Data.HashMap.Strict                  as M
@@ -161,6 +162,7 @@ processEventQueue
   :: forall m void
    . ( HasVersion
      , MonadIO m
+     , Tracing.HasReporter m
      , MonadBaseControl IO m
      , LA.Forall (LA.Pure m)
      , MonadMask m
@@ -202,6 +204,7 @@ processEventQueue logger logenv httpMgr pool getSchemaCache eeCtx@EventEngineCtx
         -- process approximately in order, minding HASURA_GRAPHQL_EVENTS_HTTP_POOL_SIZE:
         forM_ events $ \event -> do
           t <- processEvent event
+            & Tracing.runTraceT "process event"
             & withEventEngineCtx eeCtx
             & flip runReaderT (logger, httpMgr)
             & LA.async
@@ -238,6 +241,7 @@ processEventQueue logger logenv httpMgr pool getSchemaCache eeCtx@EventEngineCtx
          , MonadReader r io
          , Has HTTP.Manager r
          , Has (L.Logger L.Hasura) r
+         , Tracing.MonadTrace io
          )
       => Event -> io ()
     processEvent e = do

@@ -60,6 +60,7 @@ import           Hasura.Logging
 import           Hasura.Prelude
 import           Hasura.RQL.DDL.Headers
 import           Hasura.RQL.Types.EventTrigger
+import           Hasura.Tracing
 
 type LogEnvHeaders = Bool
 
@@ -284,13 +285,14 @@ tryWebhook ::
   , Has HTTP.Manager r
   , MonadIO m
   , MonadError (HTTPErr a) m
+  , MonadTrace m
   )
   => [HTTP.Header]
   -> HTTP.ResponseTimeout
   -> Value
   -> String
   -> m (HTTPResp a)
-tryWebhook headers timeout payload webhook = do
+tryWebhook headers timeout payload webhook = traceHttpRequest (T.pack webhook) do
   initReqE <- liftIO $ try $ HTTP.parseRequest webhook
   manager <- asks getter
   case initReqE of
@@ -303,8 +305,9 @@ tryWebhook headers timeout payload webhook = do
               , HTTP.requestBody = HTTP.RequestBodyLBS (encode payload)
               , HTTP.responseTimeout = timeout
               }
-      eitherResp <- runHTTP manager req
-      onLeft eitherResp throwError
+      pure $ SuspendedRequest req \req' -> do
+        eitherResp <- runHTTP manager req'
+        onLeft eitherResp throwError
 
 mkResp :: Int -> TBS.TByteString -> [HeaderConf] -> Response a
 mkResp status payload headers =

@@ -103,6 +103,7 @@ import qualified Data.Text                   as T
 import qualified Database.PG.Query           as Q
 import qualified Database.PG.Query.PTI       as PTI
 import qualified Hasura.Logging              as L
+import qualified Hasura.Tracing              as Tracing
 import qualified Network.HTTP.Client         as HTTP
 import qualified PostgreSQL.Binary.Decoding  as PD
 import qualified PostgreSQL.Binary.Encoding  as PE
@@ -338,7 +339,7 @@ generateScheduleTimes from n cron = take n $ go from
     go = unfoldr (fmap dup . nextMatch cron)
 
 processCronEvents
-  :: (HasVersion, MonadIO m)
+  :: (HasVersion, MonadIO m, Tracing.HasReporter m)
   => L.Logger L.Hasura
   -> LogEnvHeaders
   -> HTTP.Manager
@@ -374,7 +375,7 @@ processCronEvents logger logEnv httpMgr pgpool getSC lockedCronEvents = do
                                        ctiRetryConf
                                        ctiHeaders
                                        ctiComment
-            finally <- runExceptT $
+            finally <- Tracing.runTraceT "scheduled event" . runExceptT $
               runReaderT (processScheduledEvent logEnv pgpool scheduledEvent CronScheduledEvent) (logger, httpMgr)
             removeEventFromLockedEvents id' lockedCronEvents
             either logInternalError pure finally
@@ -383,7 +384,7 @@ processCronEvents logger logEnv httpMgr pgpool getSC lockedCronEvents = do
     logInternalError err = liftIO . L.unLogger logger $ ScheduledTriggerInternalErr err
 
 processStandAloneEvents
-  :: (HasVersion, MonadIO m)
+  :: (HasVersion, MonadIO m, Tracing.HasReporter m)
   => Env.Environment
   -> L.Logger L.Hasura
   -> LogEnvHeaders
@@ -429,7 +430,7 @@ processStandAloneEvents env logger logEnv httpMgr pgpool lockedStandAloneEvents
                                                         retryConf
                                                         headerInfo'
                                                         comment
-                finally <- runExceptT $
+                finally <- Tracing.runTraceT "scheduled event" . runExceptT $
                   runReaderT (processScheduledEvent logEnv pgpool scheduledEvent StandAloneEvent) $
                                  (logger, httpMgr)
                 removeEventFromLockedEvents id' lockedStandAloneEvents
@@ -444,7 +445,7 @@ processStandAloneEvents env logger logEnv httpMgr pgpool lockedStandAloneEvents
     logInternalError err = liftIO . L.unLogger logger $ ScheduledTriggerInternalErr err
 
 processScheduledTriggers
-  :: (HasVersion, MonadIO m)
+  :: (HasVersion, MonadIO m, Tracing.HasReporter m)
   => Env.Environment
   -> L.Logger L.Hasura
   -> LogEnvHeaders
@@ -466,6 +467,7 @@ processScheduledEvent ::
   , HasVersion
   , MonadIO m
   , MonadError QErr m
+  , Tracing.MonadTrace m
   )
   => LogEnvHeaders
   -> Q.PGPool

@@ -61,6 +61,7 @@ import qualified Hasura.GraphQL.Validate.SelectionSet   as VQ
 import qualified Hasura.GraphQL.Validate.Types          as VT
 import qualified Hasura.Logging                         as L
 import qualified Hasura.Server.Telemetry.Counters       as Telem
+import qualified Hasura.Tracing                         as Tracing
 
 -- The current execution plan of a graphql operation, it is
 -- currently, either local pg execution or a remote execution
@@ -112,6 +113,10 @@ instance MonadGQLExecutionCheck m => MonadGQLExecutionCheck (ReaderT r m) where
   checkGQLExecution ui det enableAL sc req =
     lift $ checkGQLExecution ui det enableAL sc req
 
+instance MonadGQLExecutionCheck m => MonadGQLExecutionCheck (Tracing.TraceT m) where
+  checkGQLExecution ui det enableAL sc req =
+    lift $ checkGQLExecution ui det enableAL sc req
+
 -- Enforces the current limitation
 assertSameLocationNodes
   :: (MonadError QErr m) => [VT.TypeLoc] -> m VT.TypeLoc
@@ -212,8 +217,10 @@ getResolvedExecPlan
    . ( HasVersion
      , MonadError QErr m
      , MonadIO m
+     , Tracing.MonadTrace m
      , MonadIO tx
      , MonadTx tx
+     , Tracing.MonadTrace tx
      )
   => Env.Environment
   -> PGExecCtx
@@ -304,8 +311,10 @@ getQueryOp
   :: ( HasVersion
      , MonadError QErr m
      , MonadIO m
+     , Tracing.MonadTrace m
      , MonadIO tx
      , MonadTx tx
+     , Tracing.MonadTrace tx
      )
   => Env.Environment
   -> GCtx
@@ -333,8 +342,10 @@ resolveMutSelSet
      , Has HTTP.Manager r
      , Has [HTTP.Header] r
      , MonadIO m
+     , Tracing.MonadTrace m
      , MonadIO tx
      , MonadTx tx
+     , Tracing.MonadTrace tx
      )
   => Env.Environment
   -> VQ.ObjectSelectionSet
@@ -360,8 +371,10 @@ getMutOp
   :: ( HasVersion
      , MonadError QErr m
      , MonadIO m
+     , Tracing.MonadTrace m
      , MonadIO tx
      , MonadTx tx
+     , Tracing.MonadTrace tx
      )
   => Env.Environment
   -> GCtx
@@ -392,6 +405,7 @@ getSubsOp
   :: ( MonadError QErr m
      , MonadIO m
      , HasVersion
+     , Tracing.MonadTrace m
      )
   => Env.Environment
   -> PGExecCtx
@@ -412,6 +426,7 @@ execRemoteGQ
      , MonadError QErr m
      , MonadReader ExecutionCtx m
      , MonadQueryLog m
+     , Tracing.MonadTrace m
      )
   => Env.Environment
   -> RequestId

@@ -51,6 +51,7 @@ import qualified Hasura.GraphQL.Resolve                 as GR
 import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
 import qualified Hasura.GraphQL.Validate                as GV
 import qualified Hasura.SQL.DML                         as S
+import qualified Hasura.Tracing                         as Tracing
 
 import           Hasura.Db
 import           Hasura.GraphQL.Resolve.Action
@@ -277,6 +278,7 @@ buildLiveQueryPlan
      , Has QueryCtxMap r
      , Has SQLGenCtx r
      , MonadIO m
+     , Tracing.MonadTrace m
      , HasVersion
      )
   => E.Environment