diff --git a/server/src-lib/Hasura/Eventing/HTTP.hs b/server/src-lib/Hasura/Eventing/HTTP.hs index bb297c0361de8..ac23d5ace1288 100644 --- a/server/src-lib/Hasura/Eventing/HTTP.hs +++ b/server/src-lib/Hasura/Eventing/HTTP.hs @@ -292,7 +292,7 @@ tryWebhook :: -> 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 @@ -305,7 +305,7 @@ tryWebhook headers timeout payload webhook = traceHttpRequest (T.pack webhook) d , HTTP.requestBody = HTTP.RequestBodyLBS (encode 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/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 3bd5c6aa65885..f6a1d90230e66 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 ) where import Hasura.Prelude @@ -193,9 +192,6 @@ 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) - -- | 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 @@ -208,16 +204,15 @@ extractHttpContext hdrs = do <*> pure freshSpanId <*> pure (HTTP.parseHeaderMaybe =<< lookup "X-Hasura-SpanId" hdrs) -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) @@ -234,4 +229,4 @@ traceHttpRequest name f = trace name do req' = req { HTTP.requestHeaders = tracingHeaders <> HTTP.requestHeaders req } - next req' + f req'