improve an interface of http-client instrumentation

cabal.project

@@ -21,6 +21,7 @@ packages:
   , instrumentation/wai
   , instrumentation/yesod
   , examples/grpc-echo
+  , examples/http-server
   , examples/yesod-minimal
   , examples/yesod-subsite
   , utils/exceptions

examples/http-server/main.hs

@@ -6,8 +6,10 @@ import qualified Network.HTTP.Types.Status as H
 import qualified Network.Wai as W
 import qualified Network.Wai.Handler.Warp as W
 import OpenTelemetry.Instrumentation.HttpClient (
-  httpClientInstrumentationConfig,
+  Manager (),
+  defaultManagerSettings,
   httpLbs,
+  newManager,
  )
 import OpenTelemetry.Instrumentation.Wai (newOpenTelemetryWaiMiddleware)
 import OpenTelemetry.Logging.Core (Log)
@@ -24,7 +26,6 @@ import System.Environment (getArgs)
 main :: IO ()
 main = do
   args <- getArgs
-  httpClient <- H.newManager H.defaultManagerSettings
   do
     (processors, tracerProviderOptions) <- getTracerProviderInitializationOptions
     let
@@ -35,16 +36,17 @@ main = do
           _ -> tracerProviderOptions'
     tracerProvider <- createTracerProvider processors tracerProviderOptions''
     setGlobalTracerProvider tracerProvider
+  httpClient <- newManager defaultManagerSettings
   tracerMiddleware <- newOpenTelemetryWaiMiddleware
   W.run 7777 $ tracerMiddleware $ app httpClient
 
 
-app :: H.Manager -> W.Application
+app :: Manager -> W.Application
 app httpManager req res =
   case W.pathInfo req of
     ["1"] -> do
       newReq <- H.parseRequest "http://localhost:7777/2"
-      newRes <- httpLbs httpClientInstrumentationConfig newReq httpManager
+      newRes <- httpLbs newReq httpManager
       res $ W.responseLBS H.ok200 [] $ "1 (" <> H.responseBody newRes <> ")"
     ["2"] -> res $ W.responseLBS H.ok200 [] "2"
     _ -> res $ W.responseLBS H.ok200 [] "other"

instrumentation/http-client/hs-opentelemetry-instrumentation-http-client.cabal

@@ -45,6 +45,7 @@ library
     , http-client-tls
     , http-conduit
     , http-types
+    , network
     , text
     , unliftio
     , unordered-containers
@@ -71,6 +72,7 @@ test-suite hs-opentelemetry-instrumentation-http-client-test
     , http-client-tls
     , http-conduit
     , http-types
+    , network
     , text
     , unliftio
     , unordered-containers

instrumentation/http-client/package.yaml

@@ -33,6 +33,7 @@ dependencies:
 - aeson
 - hs-opentelemetry-instrumentation-conduit >= 0.0.1 && < 0.2
 - unordered-containers
+- network
 
 library:
   ghc-options: -Wall

instrumentation/http-client/src/OpenTelemetry/Instrumentation/HttpClient.hs

@@ -1,4 +1,7 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
 
 {- | Offer a few options for HTTP instrumentation
 
@@ -8,6 +11,22 @@
 - Modify the global manager to pull from the thread-local state (least good, can't be helped sometimes)
 -}
 module OpenTelemetry.Instrumentation.HttpClient (
+  Manager (..),
+  newManager,
+  ManagerSettings (..),
+  defaultManagerSettings,
+  managerConnCount,
+  managerRawConnection,
+  managerTlsConnection,
+  managerResponseTimeout,
+  managerRetryableException,
+  managerWrapException,
+  managerIdleConnectionCount,
+  managerModifyRequest,
+  managerModifyResponse,
+  managerSetProxy,
+  managerSetInsecureProxy,
+  managerSetSecureProxy,
   withResponse,
   httpLbs,
   httpNoBody,
@@ -17,28 +36,144 @@ module OpenTelemetry.Instrumentation.HttpClient (
   module X,
 ) where
 
+import Control.Exception
 import Control.Monad.IO.Class (MonadIO (..))
 import qualified Data.ByteString.Lazy as L
 import GHC.Stack (HasCallStack, withFrozenCallStack)
-import Network.HTTP.Client as X hiding (httpLbs, httpNoBody, responseOpen, withResponse)
+import Network.HTTP.Client as X hiding (
+  Manager,
+  ManagerSettings,
+  defaultManagerSettings,
+  httpLbs,
+  httpNoBody,
+  managerConnCount,
+  managerIdleConnectionCount,
+  managerModifyRequest,
+  managerModifyResponse,
+  managerRawConnection,
+  managerResponseTimeout,
+  managerRetryableException,
+  managerSetInsecureProxy,
+  managerSetProxy,
+  managerSetSecureProxy,
+  managerTlsConnection,
+  managerWrapException,
+  newManager,
+  responseOpen,
+  withResponse,
+ )
 import qualified Network.HTTP.Client as Client
+import qualified Network.HTTP.Client.Internal as Client
+import Network.Socket (HostAddress)
 import OpenTelemetry.Context.ThreadLocal
 import OpenTelemetry.Instrumentation.HttpClient.Raw (
   HttpClientInstrumentationConfig (..),
   httpClientInstrumentationConfig,
   httpTracerProvider,
   instrumentRequest,
   instrumentResponse,
+  makeTracer,
  )
 import OpenTelemetry.Trace.Core (
   SpanArguments (kind),
   SpanKind (Client),
+  Tracer,
+  TracerProvider,
   defaultSpanArguments,
-  inSpan',
+  inSpan,
  )
 import UnliftIO (MonadUnliftIO, askRunInIO)
 
 
+data Manager = Manager
+  { originalManager :: Client.Manager
+  , tracer :: Tracer
+  , config :: HttpClientInstrumentationConfig
+  }
+
+
+instance Client.HasHttpManager Manager where
+  getHttpManager = originalManager
+
+
+data ManagerSettings = ManagerSettings
+  { originalSettings :: Client.ManagerSettings
+  , tracerProvider :: Maybe TracerProvider
+  -- ^ A used tracer provider. When you want to use the global tracer provider, set 'Nothing'.
+  , config :: HttpClientInstrumentationConfig
+  }
+
+
+defaultManagerSettings :: ManagerSettings
+defaultManagerSettings =
+  ManagerSettings
+    { originalSettings = Client.defaultManagerSettings
+    , tracerProvider = Nothing
+    , config = httpClientInstrumentationConfig
+    }
+
+
+managerConnCount :: ManagerSettings -> Int
+managerConnCount = Client.managerConnCount . originalSettings
+
+
+managerRawConnection :: ManagerSettings -> IO (Maybe HostAddress -> String -> Int -> IO Client.Connection)
+managerRawConnection = Client.managerRawConnection . originalSettings
+
+
+managerTlsConnection :: ManagerSettings -> IO (Maybe HostAddress -> String -> Int -> IO Client.Connection)
+managerTlsConnection = Client.managerTlsConnection . originalSettings
+
+
+managerResponseTimeout :: ManagerSettings -> ResponseTimeout
+managerResponseTimeout = Client.managerResponseTimeout . originalSettings
+
+
+managerRetryableException :: ManagerSettings -> SomeException -> Bool
+managerRetryableException = Client.managerRetryableException . originalSettings
+
+
+managerWrapException :: ManagerSettings -> forall a. Request -> IO a -> IO a
+managerWrapException settings = Client.managerWrapException $ originalSettings settings
+
+
+managerIdleConnectionCount :: ManagerSettings -> Int
+managerIdleConnectionCount = Client.managerIdleConnectionCount . originalSettings
+
+
+managerModifyRequest :: ManagerSettings -> Request -> IO Request
+managerModifyRequest = Client.managerModifyRequest . originalSettings
+
+
+managerModifyResponse :: ManagerSettings -> Response BodyReader -> IO (Response BodyReader)
+managerModifyResponse = Client.managerModifyResponse . originalSettings
+
+
+managerSetProxy :: ProxyOverride -> ManagerSettings -> ManagerSettings
+managerSetProxy o settings@ManagerSettings {originalSettings} =
+  settings {originalSettings = Client.managerSetProxy o originalSettings}
+
+
+managerSetInsecureProxy :: ProxyOverride -> ManagerSettings -> ManagerSettings
+managerSetInsecureProxy o settings@ManagerSettings {originalSettings} =
+  settings {originalSettings = Client.managerSetInsecureProxy o originalSettings}
+
+
+managerSetSecureProxy :: ProxyOverride -> ManagerSettings -> ManagerSettings
+managerSetSecureProxy o settings@ManagerSettings {originalSettings} =
+  settings {originalSettings = Client.managerSetSecureProxy o originalSettings}
+
+
+newManager :: ManagerSettings -> IO Manager
+newManager ManagerSettings {originalSettings, tracerProvider, config} = do
+  originalManager <- Client.newManager originalSettings
+  tracer <-
+    case tracerProvider of
+      Just tp -> pure $ makeTracer tp
+      Nothing -> httpTracerProvider
+  pure $ Manager {originalManager, tracer, config}
+
+
 spanArgs :: SpanArguments
 spanArgs = defaultSpanArguments {kind = Client}
 
@@ -60,22 +195,20 @@ spanArgs = defaultSpanArguments {kind = Client}
 -}
 withResponse ::
   (MonadUnliftIO m, HasCallStack) =>
-  HttpClientInstrumentationConfig ->
   Client.Request ->
-  Client.Manager ->
+  Manager ->
   (Client.Response Client.BodyReader -> m a) ->
   m a
-withResponse httpConf req man f =
+withResponse req Manager {originalManager, tracer, config} f =
   withFrozenCallStack $ do
-    t <- httpTracerProvider
-    inSpan' t "withResponse" spanArgs $ \_wrSpan -> do
+    inSpan tracer "withResponse" spanArgs $ do
       ctxt <- getContext
       -- TODO would like to capture the req/resp time specifically
       -- inSpan "http.request" (defaultSpanArguments { startingKind = Client }) $ \httpReqSpan -> do
-      req' <- instrumentRequest httpConf ctxt req
+      req' <- instrumentRequest tracer config ctxt req
       runInIO <- askRunInIO
-      liftIO $ Client.withResponse req' man $ \resp -> do
-        _ <- instrumentResponse httpConf ctxt resp
+      liftIO $ Client.withResponse req' originalManager $ \resp -> do
+        _ <- instrumentResponse tracer config ctxt resp
         runInIO $ f resp
 
 
@@ -85,30 +218,28 @@ withResponse httpConf req man f =
  for memory efficiency. If you are anticipating a large response body, you
  are encouraged to use 'withResponse' and 'brRead' instead.
 -}
-httpLbs :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response L.ByteString)
-httpLbs httpConf req man =
+httpLbs :: (MonadUnliftIO m, HasCallStack) => Client.Request -> Manager -> m (Client.Response L.ByteString)
+httpLbs req Manager {originalManager, tracer, config} =
   withFrozenCallStack $ do
-    t <- httpTracerProvider
-    inSpan' t "httpLbs" spanArgs $ \_ -> do
+    inSpan tracer "httpLbs" spanArgs $ do
       ctxt <- getContext
-      req' <- instrumentRequest httpConf ctxt req
-      resp <- liftIO $ Client.httpLbs req' man
-      _ <- instrumentResponse httpConf ctxt resp
+      req' <- instrumentRequest tracer config ctxt req
+      resp <- liftIO $ Client.httpLbs req' originalManager
+      _ <- instrumentResponse tracer config ctxt resp
       pure resp
 
 
 {- | A convenient wrapper around 'withResponse' which ignores the response
  body. This is useful, for example, when performing a HEAD request.
 -}
-httpNoBody :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response ())
-httpNoBody httpConf req man =
+httpNoBody :: (MonadUnliftIO m, HasCallStack) => Client.Request -> Manager -> m (Client.Response ())
+httpNoBody req Manager {originalManager, tracer, config} =
   withFrozenCallStack $ do
-    t <- httpTracerProvider
-    inSpan' t "httpNoBody" spanArgs $ \_ -> do
+    inSpan tracer "httpNoBody" spanArgs $ do
       ctxt <- getContext
-      req' <- instrumentRequest httpConf ctxt req
-      resp <- liftIO $ Client.httpNoBody req' man
-      _ <- instrumentResponse httpConf ctxt resp
+      req' <- instrumentRequest tracer config ctxt req
+      resp <- liftIO $ Client.httpNoBody req' originalManager
+      _ <- instrumentResponse tracer config ctxt resp
       pure resp
 
 
@@ -140,13 +271,12 @@ httpNoBody httpConf req man =
  Content-Encoding: and Accept-Encoding: from request and response
  headers to be relayed.
 -}
-responseOpen :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response Client.BodyReader)
-responseOpen httpConf req man =
+responseOpen :: (MonadUnliftIO m, HasCallStack) => Client.Request -> Manager -> m (Client.Response Client.BodyReader)
+responseOpen req Manager {originalManager, tracer, config} =
   withFrozenCallStack $ do
-    t <- httpTracerProvider
-    inSpan' t "responseOpen" spanArgs $ \_ -> do
+    inSpan tracer "responseOpen" spanArgs $ do
       ctxt <- getContext
-      req' <- instrumentRequest httpConf ctxt req
-      resp <- liftIO $ Client.responseOpen req' man
-      _ <- instrumentResponse httpConf ctxt resp
+      req' <- instrumentRequest tracer config ctxt req
+      resp <- liftIO $ Client.responseOpen req' originalManager
+      _ <- instrumentResponse tracer config ctxt resp
       pure resp