Tracing: Simplify HTTP traced request (hasura#5451)

Remove the Inversion of Control (SuspendRequest) and simplify
the tracing of HTTP Requests.

Co-authored-by: Phil Freeman <phil@hasura.io>

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 <naveennaidu479@gmail.com>
-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 <phil@hasura.io>

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
 

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

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)

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

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

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)

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
+-- | 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'