Capture tracing headers from incoming HTTP requests (hasura#432)

server/graphql-engine.cabal

@@ -199,6 +199,7 @@ library
 
                      , random
                      , mmorph
+                     , http-api-data
 
                      -- 0.6.1 is supposedly not okay for ghc 8.6:
                      --   https://github.com/nomeata/ghc-heap-view/issues/27

server/src-lib/Hasura/Server/App.hs

@@ -228,7 +228,11 @@ class Monad m => ConfigApiHandler m where
 -- instance (MonadIO m, UserAuthentication m, HttpLog m, Tracing.HasReporter m) => ConfigApiHandler (Tracing.TraceT m) where
 --   runConfigApiHandler = configApiGetHandler
 
-mapActionT :: (Monad m, Monad n) => (forall x. m x -> n x) -> Spock.ActionT m a -> Spock.ActionT n a
+mapActionT 
+  :: (Monad m, Monad n)
+  => (m (MTC.StT (Spock.ActionCtxT ()) a) -> n (MTC.StT (Spock.ActionCtxT ()) a))
+  -> Spock.ActionT m a
+  -> Spock.ActionT n a
 mapActionT f tma = MTC.restoreT . pure =<< MTC.liftWith \run -> f (run tma)
 
 mkSpockAction
@@ -249,10 +253,23 @@ mkSpockAction serverCtx qErrEncoder qErrModifier apiHandler = do
         manager = scManager serverCtx
         ipAddress = getSourceFromFallback req
         pathInfo = Wai.rawPathInfo req
+
+    tracingCtx <- liftIO $ Tracing.extractHttpContext headers
+
+    let runTraceT 
+          :: forall m a
+           . (MonadIO m, Tracing.HasReporter m)
+          => Tracing.TraceT m a
+          -> m a
+        runTraceT = maybe 
+          Tracing.runTraceT
+          Tracing.runTraceTWith
+          tracingCtx
+          (fromString (B8.unpack pathInfo))
 
     requestId <- getRequestId headers
 
-    mapActionT (Tracing.runTraceT (fromString (B8.unpack pathInfo))) do
+    mapActionT runTraceT do
       userInfoE <- fmap fst <$> lift (resolveUserInfo logger manager headers authMode)
       userInfo  <- either (logErrorAndResp Nothing requestId req (Left reqBody) False headers . qErrModifier)
                    return userInfoE

server/src-lib/Hasura/Tracing.hs

@@ -5,12 +5,14 @@ module Hasura.Tracing
   ( MonadTrace(..)
   , TraceT
   , runTraceT
+  , runTraceTWith
   , interpTraceT
   , TraceContext(..)
   , HasReporter(..)
   , NoReporter(..)
   , TracingMetadata
   , SuspendedRequest(..)
+  , extractHttpContext
   , traceHttpRequest
   ) where
 
@@ -22,7 +24,9 @@ import           Data.String                 (fromString)
 import qualified Data.ByteString             as BS
 import qualified Data.ByteString.Lazy        as BL
 import qualified Network.HTTP.Client         as HTTP
+import qualified Network.HTTP.Types.Header   as HTTP
 import qualified System.Random               as Rand
+import qualified Web.HttpApiData             as HTTP
 
 -- | Any additional human-readable key-value pairs relevant
 -- to the execution of a block of code.
@@ -97,6 +101,12 @@ runTraceT name tma = do
            <$> liftIO Rand.randomIO 
            <*> liftIO Rand.randomIO
            <*> pure Nothing
+  runTraceTWith ctx name tma
+
+-- | Run an action in the 'TraceT' monad transformer in an
+-- existing context.
+runTraceTWith :: HasReporter m => TraceContext -> Text -> TraceT m a -> m a
+runTraceTWith ctx name tma = do
   report ctx name $ runWriterT $ runReaderT (unTraceT tma) ctx
 
 -- | Monads which support tracing. 'TraceT' is the standard example.
@@ -152,6 +162,18 @@ instance MonadTrace m => MonadTrace (ExceptT e m) where
 -- | A HTTP request, which can be modified before execution.
 data SuspendedRequest m a = SuspendedRequest HTTP.Request (HTTP.Request -> m a)
 
+-- | Extract the trace and parent span headers from a HTTP request
+-- and create a new 'TraceContext'. The new context will contain
+-- a fresh span ID, and the provided span ID will be assigned as
+-- the immediate parent span.
+extractHttpContext :: [HTTP.Header] -> IO (Maybe TraceContext)
+extractHttpContext hdrs = do
+  freshSpanId <- liftIO Rand.randomIO
+  pure $ TraceContext 
+    <$> (HTTP.parseHeaderMaybe =<< lookup "X-Hasura-TraceId" hdrs)
+    <*> pure freshSpanId
+    <*> pure (HTTP.parseHeaderMaybe =<< lookup "X-Hasura-SpanId" hdrs)
+
 traceHttpRequest 
   :: MonadTrace m 
   => Text