From 84efaa0904fe9c99461e0551b61b633ed8e81f47 Mon Sep 17 00:00:00 2001 From: Naveen Naidu Date: Wed, 29 Jul 2020 00:21:56 +0530 Subject: [PATCH] Tracing: Simplify HTTP traced request (#5451) Remove the Inversion of Control (SuspendRequest) and simplify the tracing of HTTP Requests. Co-authored-by: Phil Freeman --- server/commit_diff.txt | 11 --------- server/src-lib/Hasura/Eventing/HTTP.hs | 4 ++-- .../src-lib/Hasura/GraphQL/Execute/Action.hs | 4 ++-- server/src-lib/Hasura/GraphQL/RemoteServer.hs | 4 ++-- .../src-lib/Hasura/GraphQL/Resolve/Action.hs | 4 ++-- server/src-lib/Hasura/Server/Auth/JWT.hs | 4 ++-- server/src-lib/Hasura/Server/Auth/WebHook.hs | 4 ++-- server/src-lib/Hasura/Tracing.hs | 24 +++++++------------ 8 files changed, 21 insertions(+), 38 deletions(-) diff --git a/server/commit_diff.txt b/server/commit_diff.txt index a005f3a035778..af28a95bfa61e 100644 --- a/server/commit_diff.txt +++ b/server/commit_diff.txt @@ -86,14 +86,3 @@ Date: Tue Jul 28 13:06:54 2020 -0700 * Typo Co-authored-by: Vamshi Surabhi <0x777@users.noreply.github.com> - -commit 664e9df9c6175cbeaf68667c415101f18c2c33aa -Author: Naveen Naidu -Date: Wed Jul 29 00:21:56 2020 +0530 - - Tracing: Simplify HTTP traced request (#5451) - - Remove the Inversion of Control (SuspendRequest) and simplify - the tracing of HTTP Requests. - - Co-authored-by: Phil Freeman diff --git a/server/src-lib/Hasura/Eventing/HTTP.hs b/server/src-lib/Hasura/Eventing/HTTP.hs index 26654e96b0f56..966be3f9b3c68 100644 --- a/server/src-lib/Hasura/Eventing/HTTP.hs +++ b/server/src-lib/Hasura/Eventing/HTTP.hs @@ -316,7 +316,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 @@ -329,7 +329,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/Execute/Action.hs b/server/src-lib/Hasura/GraphQL/Execute/Action.hs index 95ade86628eb9..4c428c60cccb5 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Action.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Action.hs @@ -417,13 +417,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/GraphQL/RemoteServer.hs b/server/src-lib/Hasura/GraphQL/RemoteServer.hs index 723cc9940102c..eb838a37522cf 100644 --- a/server/src-lib/Hasura/GraphQL/RemoteServer.hs +++ b/server/src-lib/Hasura/GraphQL/RemoteServer.hs @@ -401,7 +401,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 @@ -422,7 +422,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 0b195c8350ba2..6b3d65d0c70e3 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Action.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Action.hs @@ -444,13 +444,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 32717facff435..960d121cbc98c 100644 --- a/server/src-lib/Hasura/Server/Auth/JWT.hs +++ b/server/src-lib/Hasura/Server/Auth/JWT.hs @@ -166,10 +166,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 77d27bbecdb74..bde9257a67667 100644 --- a/server/src-lib/Hasura/Server/Auth/WebHook.hs +++ b/server/src-lib/Hasura/Server/Auth/WebHook.hs @@ -74,10 +74,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 da85767e124e5..098ede166cf16 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,9 +197,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) - -- | Inject the trace context as a set of HTTP headers. injectHttpContext :: TraceContext -> [HTTP.Header] injectHttpContext TraceContext{..} = @@ -208,7 +204,6 @@ injectHttpContext TraceContext{..} = , ("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 +-- | Perform HTTP request which supports Trace headers +tracedHttpRequest :: 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 + => 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'