diff --git a/server/src-lib/Hasura/Eventing/HTTP.hs b/server/src-lib/Hasura/Eventing/HTTP.hs index a72cebca4afb5..bfc0cbca64e5a 100644 --- a/server/src-lib/Hasura/Eventing/HTTP.hs +++ b/server/src-lib/Hasura/Eventing/HTTP.hs @@ -313,7 +313,7 @@ tryWebhook :: -- it the final request body, instead of 'Value' -> String -> m (HTTPResp a) -tryWebhook headers timeout payload webhook = traceHttpRequest (T.pack webhook) $ do +tryWebhook headers timeout payload webhook = do initReqE <- liftIO $ try $ HTTP.parseRequest webhook manager <- asks getter case initReqE of @@ -326,7 +326,7 @@ tryWebhook headers timeout payload webhook = traceHttpRequest (T.pack webhook) $ , HTTP.requestBody = HTTP.RequestBodyLBS payload , HTTP.responseTimeout = timeout } - pure $ SuspendedRequest req $ \req' -> do + tracedHttpRequest req $ \req' -> do eitherResp <- runHTTP manager req' onLeft eitherResp throwError diff --git a/server/src-lib/Hasura/GraphQL/RemoteServer.hs b/server/src-lib/Hasura/GraphQL/RemoteServer.hs index c5c75c446764c..2c14bb43517b6 100644 --- a/server/src-lib/Hasura/GraphQL/RemoteServer.hs +++ b/server/src-lib/Hasura/GraphQL/RemoteServer.hs @@ -359,7 +359,7 @@ execRemoteGQ' -> RemoteSchemaInfo -> G.OperationType -> m (DiffTime, [N.Header], BL.ByteString) -execRemoteGQ' env manager userInfo reqHdrs q rsi opType = Tracing.traceHttpRequest (T.pack (show url)) $ do +execRemoteGQ' env manager userInfo reqHdrs q rsi opType = do when (opType == G.OperationTypeSubscription) $ throw400 NotSupported "subscription to remote server is not supported" confHdrs <- makeHeadersFromConf env hdrConf @@ -380,7 +380,7 @@ execRemoteGQ' env manager userInfo reqHdrs q rsi opType = Tracing.traceHttpReque , HTTP.requestBody = HTTP.RequestBodyLBS (J.encode q) , HTTP.responseTimeout = HTTP.responseTimeoutMicro (timeout * 1000000) } - pure $ Tracing.SuspendedRequest req \req' -> do + Tracing.tracedHttpRequest req \req' -> do (time, res) <- withElapsedTime $ liftIO $ try $ HTTP.httpLbs req' manager resp <- either httpThrow return res pure (time, mkSetCookieHeaders resp, resp ^. Wreq.responseBody) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Action.hs b/server/src-lib/Hasura/GraphQL/Resolve/Action.hs index 095f38bb74f85..002af5c34ebf1 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Action.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Action.hs @@ -503,13 +503,13 @@ callWebhook env manager outputType outputFields reqHeaders confHeaders hdrs = contentType : (Map.toList . Map.fromList) (resolvedConfHeaders <> clientHeaders) postPayload = J.toJSON actionWebhookPayload url = unResolvedWebhook resolvedWebhook - httpResponse <- Tracing.traceHttpRequest url do + httpResponse <- do initReq <- liftIO $ HTTP.parseRequest (T.unpack url) let req = initReq { HTTP.method = "POST" , HTTP.requestHeaders = addDefaultHeaders hdrs , HTTP.requestBody = HTTP.RequestBodyLBS (J.encode postPayload) } - pure $ Tracing.SuspendedRequest req \req' -> + Tracing.tracedHttpRequest req \req' -> liftIO . try $ HTTP.httpLbs req' manager let requestInfo = ActionRequestInfo url postPayload $ confHeaders <> toHeadersConf clientHeaders diff --git a/server/src-lib/Hasura/Server/App.hs b/server/src-lib/Hasura/Server/App.hs index cad1fd4306f5a..ebc3c2b857113 100644 --- a/server/src-lib/Hasura/Server/App.hs +++ b/server/src-lib/Hasura/Server/App.hs @@ -275,9 +275,13 @@ mkSpockAction serverCtx qErrEncoder qErrModifier apiHandler = do tracingCtx (fromString (B8.unpack pathInfo)) - requestId <- getRequestId headers - + requestId <- getRequestId headers + mapActionT runTraceT $ do + -- Add the request ID to the tracing metadata so that we + -- can correlate requests and traces + lift $ Tracing.attachMetadata [("request_id", unRequestId requestId)] + userInfoE <- fmap fst <$> lift (resolveUserInfo logger manager headers authMode) userInfo <- either (logErrorAndResp Nothing requestId req (reqBody, Nothing) False headers . qErrModifier) return userInfoE diff --git a/server/src-lib/Hasura/Server/Auth/JWT.hs b/server/src-lib/Hasura/Server/Auth/JWT.hs index cc07b0ddc3b2f..a489606ec54fc 100644 --- a/server/src-lib/Hasura/Server/Auth/JWT.hs +++ b/server/src-lib/Hasura/Server/Auth/JWT.hs @@ -165,10 +165,10 @@ updateJwkRef (Logger logger) manager url jwkRef = do let urlT = T.pack $ show url infoMsg = "refreshing JWK from endpoint: " <> urlT liftIO $ logger $ JwkRefreshLog LevelInfo (Just infoMsg) Nothing - res <- try $ Tracing.traceHttpRequest urlT do + res <- try $ do initReq <- liftIO $ HTTP.parseRequest $ show url let req = initReq { HTTP.requestHeaders = addDefaultHeaders (HTTP.requestHeaders initReq) } - pure $ Tracing.SuspendedRequest req \req' -> do + Tracing.tracedHttpRequest req \req' -> do liftIO $ HTTP.httpLbs req' manager resp <- either logAndThrowHttp return res let status = resp ^. Wreq.responseStatus diff --git a/server/src-lib/Hasura/Server/Auth/WebHook.hs b/server/src-lib/Hasura/Server/Auth/WebHook.hs index 005d3f260bfa6..9f99fa75923bb 100644 --- a/server/src-lib/Hasura/Server/Auth/WebHook.hs +++ b/server/src-lib/Hasura/Server/Auth/WebHook.hs @@ -75,10 +75,10 @@ userInfoFromAuthHook logger manager hook reqHeaders = do mkUserInfoFromResp logger (ahUrl hook) (hookMethod hook) status respBody where performHTTPRequest :: m (Wreq.Response BL.ByteString) - performHTTPRequest = Tracing.traceHttpRequest (ahUrl hook) do + performHTTPRequest = do let url = T.unpack $ ahUrl hook req <- liftIO $ H.parseRequest url - pure $ Tracing.SuspendedRequest req \req' -> liftIO do + Tracing.tracedHttpRequest req \req' -> liftIO do case ahType hook of AHTGet -> do let isCommonHeader = (`elem` commonClientHeadersIgnored) diff --git a/server/src-lib/Hasura/Tracing.hs b/server/src-lib/Hasura/Tracing.hs index d1d90a01a7f91..9f1fea6074cac 100644 --- a/server/src-lib/Hasura/Tracing.hs +++ b/server/src-lib/Hasura/Tracing.hs @@ -14,9 +14,8 @@ module Hasura.Tracing , noReporter , HasReporter(..) , TracingMetadata - , SuspendedRequest(..) , extractHttpContext - , traceHttpRequest + , tracedHttpRequest , injectEventContext , extractEventContext ) where @@ -198,17 +197,13 @@ instance MonadTrace m => MonadTrace (ExceptT e m) where currentReporter = lift currentReporter attachMetadata = lift . attachMetadata --- | A HTTP request, which can be modified before execution. -data SuspendedRequest m a = SuspendedRequest HTTP.Request (HTTP.Request -> m a) - -- | Inject the trace context as a set of HTTP headers. injectHttpContext :: TraceContext -> [HTTP.Header] injectHttpContext TraceContext{..} = [ ("X-Hasura-TraceId", fromString (show tcCurrentTrace)) , ("X-Hasura-SpanId", fromString (show tcCurrentSpan)) ] - - + -- | 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 @@ -239,16 +234,15 @@ extractEventContext e = do <*> pure freshSpanId <*> pure (e ^? JL.key "trace_context" . JL.key "span_id" . JL._Integral) -traceHttpRequest - :: MonadTrace m - => Text - -- ^ human-readable name for this block of code - -> m (SuspendedRequest m a) - -- ^ an action which yields the request about to be executed and suspends - -- before actually executing it +-- | Perform HTTP request which supports Trace headers +tracedHttpRequest + :: MonadTrace m + => HTTP.Request + -- ^ http request that needs to be made + -> (HTTP.Request -> m a) + -- ^ a function that takes the traced request and executes it -> m a -traceHttpRequest name f = trace name do - SuspendedRequest req next <- f +tracedHttpRequest req f = trace (bsToTxt (HTTP.path req)) do let reqBytes = case HTTP.requestBody req of HTTP.RequestBodyBS bs -> Just (fromIntegral (BS.length bs)) HTTP.RequestBodyLBS bs -> Just (BL.length bs) @@ -261,4 +255,4 @@ traceHttpRequest name f = trace name do let req' = req { HTTP.requestHeaders = injectHttpContext ctx <> HTTP.requestHeaders req } - next req' + f req'