hs-opentelemetry-instrumentation-http-client 0.1.0.2 → 1.0.0.0

raw patch · 8 files changed

+870/−209 lines, 8 filesdep +hs-opentelemetry-exporter-in-memorydep +hs-opentelemetry-instrumentation-http-clientdep +hs-opentelemetry-sdkdep ~hs-opentelemetry-apidep ~hs-opentelemetry-instrumentation-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: hs-opentelemetry-exporter-in-memory, hs-opentelemetry-instrumentation-http-client, hs-opentelemetry-sdk, hs-opentelemetry-semantic-conventions, hspec

Dependency ranges changed: hs-opentelemetry-api, hs-opentelemetry-instrumentation-conduit

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• LICENSE +1/−1
• README.md +2/−0
• hs-opentelemetry-instrumentation-http-client.cabal +39/−14
• src/OpenTelemetry/Instrumentation/HttpClient.hs +149/−62
• src/OpenTelemetry/Instrumentation/HttpClient/Raw.hs +487/−116
• src/OpenTelemetry/Instrumentation/HttpClient/Simple.hs +76/−16
• test/Spec.hs +106/−0

@@ -1,5 +1,15 @@ # Changelog for hs-opentelemetry-instrumentation-http-client +## Unreleased++## 1.0.0.0 - 2026-05-29++- **Fix: stable attribute `http.host` → `server.address`.** The stable+  HTTP semantic conventions use `server.address` and `server.port` instead+  of the legacy `http.host`.+- Add `error.type` attribute on HTTP error responses (status >= 400).+- Fix span name to use HTTP method (low-cardinality) instead of full URL.+ ## 0.1.0.2  - Relax `hs-opentelemetry-api` bounds to support 0.3.x

@@ -1,4 +1,4 @@-Copyright Ian Duncan (c) 2021+Copyright Ian Duncan (c) 2021-2026  All rights reserved. 

@@ -1,1 +1,3 @@ # hs-opentelemetry-instrumentation-http-client++[![hs-opentelemetry-instrumentation-http-client](https://img.shields.io/hackage/v/hs-opentelemetry-instrumentation-http-client?style=flat-square&logo=haskell&label=hs-opentelemetry-instrumentation-http-client&labelColor=5D4F85)](https://hackage.haskell.org/package/hs-opentelemetry-instrumentation-http-client)

@@ -1,20 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack -name:               hs-opentelemetry-instrumentation-http-client-version:            0.1.0.2-description:        Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/http-client#readme>-homepage:           https://github.com/iand675/hs-opentelemetry#readme-bug-reports:        https://github.com/iand675/hs-opentelemetry/issues-author:             Ian Duncan, Jade Lovelace-maintainer:         ian@iankduncan.com-copyright:          2024 Ian Duncan, Mercury Technologies-license:            BSD3-license-file:       LICENSE-build-type:         Simple+name:           hs-opentelemetry-instrumentation-http-client+version:        1.0.0.0+synopsis:       OpenTelemetry instrumentation for http-client+description:    Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/http-client#readme>+category:       OpenTelemetry, Telemetry, HTTP, Web+homepage:       https://github.com/iand675/hs-opentelemetry#readme+bug-reports:    https://github.com/iand675/hs-opentelemetry/issues+author:         Ian Duncan, Jade Lovelace+maintainer:     ian@iankduncan.com+copyright:      2024 Ian Duncan, Mercury Technologies+license:        BSD3+license-file:   LICENSE+build-type:     Simple extra-source-files:     README.md     ChangeLog.md@@ -39,12 +41,35 @@     , bytestring     , case-insensitive     , conduit-    , hs-opentelemetry-api ==0.3.*-    , hs-opentelemetry-instrumentation-conduit >=0.0.1 && <0.2+    , hs-opentelemetry-api ==1.0.*+    , hs-opentelemetry-instrumentation-conduit ==1.0.*+    , hs-opentelemetry-semantic-conventions >=1.40 && <2     , http-client     , http-conduit     , http-types     , text     , unliftio+    , unordered-containers+  default-language: Haskell2010++test-suite hs-opentelemetry-instrumentation-http-client-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_hs_opentelemetry_instrumentation_http_client+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , hs-opentelemetry-api ==1.0.*+    , hs-opentelemetry-exporter-in-memory ==1.0.*+    , hs-opentelemetry-instrumentation-http-client ==1.0.*+    , hs-opentelemetry-sdk ==1.0.*+    , hs-opentelemetry-semantic-conventions >=1.40 && <2+    , hspec+    , http-client+    , http-types+    , text     , unordered-containers   default-language: Haskell2010

@@ -1,24 +1,81 @@ {-# LANGUAGE OverloadedStrings #-} -{- | Offer a few options for HTTP instrumentation+{- |+Module      : OpenTelemetry.Instrumentation.HttpClient+Copyright   : (c) Ian Duncan, 2021-2026+License     : BSD-3+Description : Automatic tracing for http-client requests+Stability   : experimental -- Add attributes via 'Request' and 'Response' to an existing span (Best)-- Use internals to instrument a particular callsite using modifyRequest, modifyResponse (Next best)-- Provide a middleware to pull from the thread-local state (okay)-- Modify the global manager to pull from the thread-local state (least good, can't be helped sometimes)+= Overview -[New HTTP semantic conventions have been declared stable.](https://opentelemetry.io/blog/2023/http-conventions-declared-stable/#migration-plan) Opt-in by setting the environment variable OTEL_SEMCONV_STABILITY_OPT_IN to-- "http" - to use the stable conventions-- "http/dup" - to emit both the old and the stable conventions-Otherwise, the old conventions will be used. The stable conventions will replace the old conventions in the next major release of this library.+Instruments outbound HTTP requests made with the @http-client@ library.+Creates a @Client@ span for each request and injects trace context into+request headers so downstream services can continue the trace.++= Quick example++The usual approach is to build a 'Manager' with traced settings once; spans+use the tracer from 'OpenTelemetry.Instrumentation.HttpClient.Raw.httpTracerProvider'+(typically the global tracer provider):++@+import Network.HTTP.Client.TLS (tlsManagerSettings)+import OpenTelemetry.Instrumentation.HttpClient+  ( httpLbs+  , httpClientInstrumentationConfig+  , newTracedManager+  )++main :: IO ()+main = do+  manager <- newTracedManager httpClientInstrumentationConfig tlsManagerSettings+  response <- httpLbs request manager+  ...+@++For custom manager settings, apply 'OpenTelemetry.Instrumentation.HttpClient.Raw.instrumentManagerSettings'+before @newManager@. You can also use 'tracedHttpRequest' or the prime-suffixed+variants (e.g. 'httpLbs'') for per-call configuration; see the export list below.++= What gets traced++Each outbound request creates a @Client@ span with:++* Span name: @METHOD host@ (e.g. @GET api.example.com@)+* @http.request.method@, @url.full@, @server.address@, @server.port@+* @http.response.status_code@, @http.response.body.size@+* Trace context injected into request headers via the global propagator++[HTTP semantic conventions migration:](https://opentelemetry.io/blog/2023/http-conventions-declared-stable/#migration-plan)+opt in via @OTEL_SEMCONV_STABILITY_OPT_IN@ (@http@, @http/dup@, or default legacy). -} module OpenTelemetry.Instrumentation.HttpClient (+  -- * Manager-level instrumentation (recommended)+  instrumentManagerSettings,+  newTracedManager,+  httpClientPropagateHeaders,++  -- * Per-request combinator+  tracedHttpRequest,++  -- * Drop-in replacements (zero-config)   withResponse,   httpLbs,   httpNoBody,   responseOpen,++  -- * Drop-in replacements (with config)+  withResponse',+  httpLbs',+  httpNoBody',+  responseOpen',++  -- * Configuration   httpClientInstrumentationConfig,   HttpClientInstrumentationConfig (..),++  -- * Re-exports   module X, ) where @@ -31,9 +88,13 @@ import OpenTelemetry.Instrumentation.HttpClient.Raw (   HttpClientInstrumentationConfig (..),   httpClientInstrumentationConfig,+  httpClientPropagateHeaders,   httpTracerProvider,+  instrumentManagerSettings,   instrumentRequest,   instrumentResponse,+  newTracedManager,+  tracedHttpRequest,  ) import OpenTelemetry.Trace.Core (   SpanArguments (kind),@@ -50,34 +111,70 @@ spanArgs = defaultSpanArguments {kind = Client}  -{- | Instrumented variant of @Network.HTTP.Client.withResponse@+{- | 'withResponse' with default instrumentation config. - Perform a @Request@ using a connection acquired from the given @Manager@,- and then provide the @Response@ to the given function. This function is- fully exception safe, guaranteeing that the response will be closed when the- inner function exits. It is defined as:+@since 0.2.0.0+-}+withResponse+  :: (MonadUnliftIO m, HasCallStack)+  => Client.Request+  -> Client.Manager+  -> (Client.Response Client.BodyReader -> m a)+  -> m a+withResponse = withResponse' mempty - > withResponse req man f = bracket (responseOpen req man) responseClose f - It is recommended that you use this function in place of explicit calls to- 'responseOpen' and 'responseClose'.+{- | 'httpLbs' with default instrumentation config. - You will need to use functions such as 'brRead' to consume the response- body.+@since 0.2.0.0 -}-withResponse+httpLbs   :: (MonadUnliftIO m, HasCallStack)+  => Client.Request+  -> Client.Manager+  -> m (Client.Response L.ByteString)+httpLbs = httpLbs' mempty+++{- | 'httpNoBody' with default instrumentation config.++@since 0.2.0.0+-}+httpNoBody+  :: (MonadUnliftIO m, HasCallStack)+  => Client.Request+  -> Client.Manager+  -> m (Client.Response ())+httpNoBody = httpNoBody' mempty+++{- | 'responseOpen' with default instrumentation config.++@since 0.2.0.0+-}+responseOpen+  :: (MonadUnliftIO m, HasCallStack)+  => Client.Request+  -> Client.Manager+  -> m (Client.Response Client.BodyReader)+responseOpen = responseOpen' mempty+++{- | Instrumented 'Client.withResponse' with explicit config.++@since 0.2.0.0+-}+withResponse'+  :: (MonadUnliftIO m, HasCallStack)   => HttpClientInstrumentationConfig   -> Client.Request   -> Client.Manager   -> (Client.Response Client.BodyReader -> m a)   -> m a-withResponse httpConf req man f = do+withResponse' httpConf req man f = do   tracer <- httpTracerProvider   inSpan'' tracer "withResponse" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_wrSpan -> 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     runInIO <- askRunInIO     liftIO $ Client.withResponse req' man $ \resp -> do@@ -85,14 +182,17 @@       runInIO $ f resp  -{- | A convenience wrapper around 'withResponse' which reads in the entire- response body and immediately closes the connection. Note that this function- performs fully strict I\/O, and only uses a lazy ByteString in its response- for memory efficiency. If you are anticipating a large response body, you- are encouraged to use 'withResponse' and 'brRead' instead.+{- | Instrumented 'Client.httpLbs' with explicit config.++@since 0.2.0.0 -}-httpLbs :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response L.ByteString)-httpLbs httpConf req man = do+httpLbs'+  :: (MonadUnliftIO m, HasCallStack)+  => HttpClientInstrumentationConfig+  -> Client.Request+  -> Client.Manager+  -> m (Client.Response L.ByteString)+httpLbs' httpConf req man = do   tracer <- httpTracerProvider   inSpan'' tracer "httpLbs" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_ -> do     ctxt <- getContext@@ -102,11 +202,17 @@     pure resp  -{- | A convenient wrapper around 'withResponse' which ignores the response- body. This is useful, for example, when performing a HEAD request.+{- | Instrumented 'Client.httpNoBody' with explicit config.++@since 0.2.0.0 -}-httpNoBody :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response ())-httpNoBody httpConf req man = do+httpNoBody'+  :: (MonadUnliftIO m, HasCallStack)+  => HttpClientInstrumentationConfig+  -> Client.Request+  -> Client.Manager+  -> m (Client.Response ())+httpNoBody' httpConf req man = do   tracer <- httpTracerProvider   inSpan'' tracer "httpNoBody" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_ -> do     ctxt <- getContext@@ -116,36 +222,17 @@     pure resp  -{- | The most low-level function for initiating an HTTP request.-- The first argument to this function gives a full specification- on the request: the host to connect to, whether to use SSL,- headers, etc. Please see 'Request' for full details.  The- second argument specifies which 'Manager' should be used.-- This function then returns a 'Response' with a- 'BodyReader'.  The 'Response' contains the status code- and headers that were sent back to us, and the- 'BodyReader' contains the body of the request.  Note- that this 'BodyReader' allows you to have fully- interleaved IO actions during your HTTP download, making it- possible to download very large responses in constant memory.-- An important note: the response body returned by this function represents a- live HTTP connection. As such, if you do not use the response body, an open- socket will be retained indefinitely. You must be certain to call- 'responseClose' on this response to free up resources.-- This function automatically performs any necessary redirects, as specified- by the 'redirectCount' setting.+{- | Instrumented 'Client.responseOpen' with explicit config. - When implementing a (reverse) proxy using this function or relating- functions, it's wise to remove Transfer-Encoding:, Content-Length:,- Content-Encoding: and Accept-Encoding: from request and response- headers to be relayed.+@since 0.2.0.0 -}-responseOpen :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response Client.BodyReader)-responseOpen httpConf req man = do+responseOpen'+  :: (MonadUnliftIO m, HasCallStack)+  => HttpClientInstrumentationConfig+  -> Client.Request+  -> Client.Manager+  -> m (Client.Response Client.BodyReader)+responseOpen' httpConf req man = do   tracer <- httpTracerProvider   inSpan'' tracer "responseOpen" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_ -> do     ctxt <- getContext

@@ -1,40 +1,91 @@+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -module OpenTelemetry.Instrumentation.HttpClient.Raw where+{- |+Module      : OpenTelemetry.Instrumentation.HttpClient.Raw+Description : Low-level HTTP client instrumentation.+Stability   : experimental +Provides raw request/response hooks for creating spans around HTTP calls.+-}+module OpenTelemetry.Instrumentation.HttpClient.Raw (+  -- * Manager-level instrumentation+  instrumentManagerSettings,+  newTracedManager,+  httpClientPropagateHeaders,++  -- * Per-request combinator+  tracedHttpRequest,++  -- * Low-level building blocks+  instrumentRequest,+  instrumentResponse,+  instrumentResponseOnSpan,++  -- * Configuration+  HttpClientInstrumentationConfig (..),+  httpClientInstrumentationConfig,++  -- * Metrics+  HttpClientMetrics (..),+  createHttpClientMetrics,+  createHttpClientMetricsFromMeter,++  -- * Internal+  httpTracerProvider,+  httpVersionText,+) where+ import Control.Applicative ((<|>))+import Control.Exception (SomeException, catch, throwIO) import Control.Monad (forM_, when) import Control.Monad.IO.Class import qualified Data.ByteString.Char8 as B import Data.CaseInsensitive (foldedCase)+import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as H+import Data.Int (Int64) import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Lazy.Builder.Int (decimal)+import Data.Typeable (tyConName, typeOf, typeRepTyCon)+import Data.Word (Word64) import Network.HTTP.Client import Network.HTTP.Types-import OpenTelemetry.Context (Context, lookupSpan)+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Context (insertSpan, lookupSpan)+import qualified OpenTelemetry.Context as Ctx import OpenTelemetry.Context.ThreadLocal-import OpenTelemetry.Propagator+import OpenTelemetry.Metric.Core+import OpenTelemetry.Propagator (TextMap, TextMapPropagator, extract, getGlobalTextMapPropagator, inject, textMapFromList, textMapToList)+import qualified OpenTelemetry.SemanticConventions as SC import OpenTelemetry.SemanticsConfig import OpenTelemetry.Trace.Core+import System.IO.Unsafe (unsafePerformIO)   data HttpClientInstrumentationConfig = HttpClientInstrumentationConfig   { requestName :: Maybe T.Text   , requestHeadersToRecord :: [HeaderName]   , responseHeadersToRecord :: [HeaderName]+  , httpClientMetrics :: Maybe HttpClientMetrics   }   instance Semigroup HttpClientInstrumentationConfig where   l <> r =     HttpClientInstrumentationConfig-      { requestName = requestName r <|> requestName l -- flipped on purpose: last writer wins+      { requestName = requestName r <|> requestName l       , requestHeadersToRecord = requestHeadersToRecord l <> requestHeadersToRecord r       , responseHeadersToRecord = responseHeadersToRecord l <> responseHeadersToRecord r+      , httpClientMetrics = httpClientMetrics r <|> httpClientMetrics l       }  @@ -44,6 +95,7 @@       { requestName = Nothing       , requestHeadersToRecord = mempty       , responseHeadersToRecord = mempty+      , httpClientMetrics = Nothing       }  @@ -51,142 +103,461 @@ httpClientInstrumentationConfig = mempty  --- TODO see if we can avoid recreating this on each request without being more invasive with the interface+-- Context key for the span created by Manager-level hooks, so we can+-- retrieve "our" span in managerModifyResponse without confusing it with+-- a caller's span.+managedSpanKey :: Ctx.Key Span+managedSpanKey = unsafePerformIO $ Ctx.newKey "http-client.managed-span"+{-# NOINLINE managedSpanKey #-}+++-- Context key to stash the attach token so we can restore context+-- after managerModifyResponse completes.+parentTokenKey :: Ctx.Key Token+parentTokenKey = unsafePerformIO $ Ctx.newKey "http-client.parent-token"+{-# NOINLINE parentTokenKey #-}+++metricStartKey :: Ctx.Key (Word64, Request)+metricStartKey = unsafePerformIO $ Ctx.newKey "http-client.metric-start"+{-# NOINLINE metricStartKey #-}++ httpTracerProvider :: (MonadIO m) => m Tracer httpTracerProvider = do   tp <- getGlobalTracerProvider   pure $ makeTracer tp $detectInstrumentationLibrary tracerOptions  -instrumentRequest+data HttpClientMetrics = HttpClientMetrics+  { hcmDuration :: !Histogram+  , hcmActive :: !(UpDownCounter Int64)+  , hcmCount :: !(Counter Int64)+  }+++createHttpClientMetrics :: IO HttpClientMetrics+createHttpClientMetrics = do+  mp <- getGlobalMeterProvider+  meter <- getMeter mp "hs-opentelemetry-instrumentation-http-client"+  createHttpClientMetricsFromMeter meter+++createHttpClientMetricsFromMeter :: Meter -> IO HttpClientMetrics+createHttpClientMetricsFromMeter meter = do+  dur <-+    meterCreateHistogram+      meter+      "http.client.request.duration"+      (Just "s")+      (Just "Duration of outbound HTTP requests")+      defaultAdvisoryParameters+        { advisoryExplicitBucketBoundaries =+            Just [0.005, 0.01, 0.025, 0.05, 0.075, 0.1, 0.25, 0.5, 0.75, 1.0, 2.5, 5.0, 7.5, 10.0]+        }+  active <- meterCreateUpDownCounterInt64 meter "http.client.active_requests" (Just "{request}") (Just "Number of active outbound HTTP requests") defaultAdvisoryParameters+  cnt <- meterCreateCounterInt64 meter "http.client.request.count" (Just "{request}") (Just "Total number of outbound HTTP requests") defaultAdvisoryParameters+  pure HttpClientMetrics {hcmDuration = dur, hcmActive = active, hcmCount = cnt}+++resolveMetrics :: HttpClientInstrumentationConfig -> IO HttpClientMetrics+resolveMetrics conf = maybe createHttpClientMetrics pure (httpClientMetrics conf)+++metricRequestAttrs :: Request -> A.Attributes+metricRequestAttrs req =+  let a1 = A.addAttribute A.defaultAttributeLimits A.emptyAttributes (unkey SC.http_request_method) (T.decodeUtf8 (method req))+      a2 = A.addAttribute A.defaultAttributeLimits a1 (unkey SC.server_address) (T.decodeUtf8 (host req))+      a3 = A.addAttribute A.defaultAttributeLimits a2 (unkey SC.server_port) (port req)+  in a3+++recordResponseMetrics :: HttpClientMetrics -> Request -> Word64 -> Word64 -> Response a -> IO ()+recordResponseMetrics hcm req startNs endNs resp = do+  let sc = statusCode (responseStatus resp)+      durationSec = fromIntegral (endNs - startNs) / 1_000_000_000 :: Double+      base = metricRequestAttrs req+      a1 = A.addAttribute A.defaultAttributeLimits base (unkey SC.http_response_statusCode) sc+      a2 = A.addAttribute A.defaultAttributeLimits a1 (unkey SC.network_protocol_version) (httpVersionText (responseVersion resp))+      respAttrs+        | sc >= 400 = A.addAttribute A.defaultAttributeLimits a2 (unkey SC.error_type) (T.pack (show sc))+        | otherwise = a2+  histogramRecord (hcmDuration hcm) durationSec respAttrs+  counterAdd (hcmCount hcm) 1 respAttrs+++recordErrorMetrics :: HttpClientMetrics -> Request -> Word64 -> Word64 -> SomeException -> IO ()+recordErrorMetrics hcm req startNs endNs ex = do+  let durationSec = fromIntegral (endNs - startNs) / 1_000_000_000 :: Double+      base = metricRequestAttrs req+      errType = T.pack $ tyConName $ typeRepTyCon $ typeOf ex+      errAttrs = A.addAttribute A.defaultAttributeLimits base (unkey SC.error_type) errType+  histogramRecord (hcmDuration hcm) durationSec errAttrs+  counterAdd (hcmCount hcm) 1 errAttrs+++{- | Instrument a 'ManagerSettings' to automatically trace all HTTP requests.++Each request through the resulting 'Manager' will:++1. Create a client span named after the HTTP method (e.g., @\"GET\"@, @\"POST\"@)+2. Add request\/response attributes per the OTel HTTP semantic conventions+3. Inject context propagation headers (e.g., @traceparent@, @tracestate@)+4. Record response status code and set error status for 4xx\/5xx+5. End the span when the response is received (or on exception)++This is the recommended way to instrument http-client. Set it up once+at 'Manager' creation time and all requests — including those from+third-party libraries — are automatically traced.++@+settings <- 'instrumentManagerSettings' 'httpClientInstrumentationConfig' tlsManagerSettings+manager <- 'newManager' settings+-- All requests through this manager are now traced:+resp <- Client.httpLbs req manager+@++@since 0.2.0.0+-}+instrumentManagerSettings+  :: HttpClientInstrumentationConfig+  -> ManagerSettings+  -> IO ManagerSettings+instrumentManagerSettings conf settings = do+  tracer <- httpTracerProvider+  hcm <- resolveMetrics conf+  pure $+    settings+      { managerModifyRequest = \req -> do+          req' <- managerModifyRequest settings req+          parentCtx <- getContext++          let methodText = T.decodeUtf8 (method req')+              reqSpanName = fromMaybe methodText (requestName conf)++          s <-+            createSpanWithoutCallStack+              tracer+              parentCtx+              reqSpanName+              defaultSpanArguments {kind = Client}++          let newCtx =+                Ctx.insert managedSpanKey s+                  . insertSpan s+                  $ parentCtx++          tok <- attachContext newCtx+          adjustContext (Ctx.insert parentTokenKey tok)++          upDownCounterAdd (hcmActive hcm) 1 (metricRequestAttrs req')++          addRequestAttributes conf s req'++          propagator <- getGlobalTextMapPropagator+          ctx' <- getContext+          hdrs <- injectToHeaders propagator ctx' (requestHeaders req')+          startTs <- getTimestamp+          adjustContext (Ctx.insert metricStartKey (timestampNanoseconds startTs, req'))+          pure req' {requestHeaders = hdrs}+      , managerModifyResponse = \resp -> do+          resp' <- managerModifyResponse settings resp+          ctx <- getContext+          forM_ (Ctx.lookup managedSpanKey ctx) $ \s -> do+            instrumentResponseOnSpan conf s resp'+            endSpan s Nothing+          forM_ (Ctx.lookup metricStartKey ctx) $ \(startNs, origReq) -> do+            endTs <- getTimestamp+            upDownCounterAdd (hcmActive hcm) (-1) (metricRequestAttrs origReq)+            recordResponseMetrics hcm origReq startNs (timestampNanoseconds endTs) resp'+          forM_ (Ctx.lookup parentTokenKey ctx) detachContext+          pure resp'+      , managerWrapException = \req action ->+          managerWrapException settings req action `catch` \(e :: SomeException) -> do+            ctx <- getContext+            forM_ (Ctx.lookup managedSpanKey ctx) $ \s -> do+              let errText = T.pack (show e)+              addAttributes s [(unkey SC.error_type, toAttribute errText)]+              setStatus s (Error errText)+              endSpan s Nothing+            forM_ (Ctx.lookup metricStartKey ctx) $ \(startNs, origReq) -> do+              endTs <- getTimestamp+              upDownCounterAdd (hcmActive hcm) (-1) (metricRequestAttrs origReq)+              recordErrorMetrics hcm origReq startNs (timestampNanoseconds endTs) e+            forM_ (Ctx.lookup parentTokenKey ctx) detachContext+            throwIO e+      }+++{- | Create a new 'Manager' with automatic tracing. Convenience wrapper+around 'instrumentManagerSettings' and 'newManager'.++@+manager <- 'newTracedManager' 'httpClientInstrumentationConfig' defaultManagerSettings+@++@since 0.2.0.0+-}+newTracedManager :: HttpClientInstrumentationConfig -> ManagerSettings -> IO Manager+newTracedManager conf settings = do+  settings' <- instrumentManagerSettings conf settings+  newManager settings'+++{- | Lightweight variant that only injects context propagation headers+(e.g., @traceparent@, @tracestate@) without creating spans. Useful when+spans are managed elsewhere (e.g., via @inSpan@) but you still want+outgoing requests to carry trace context.++@+settings <- 'httpClientPropagateHeaders' defaultManagerSettings+manager <- 'newManager' settings+@++@since 0.2.0.0+-}+httpClientPropagateHeaders :: ManagerSettings -> IO ManagerSettings+httpClientPropagateHeaders settings =+  pure $+    settings+      { managerModifyRequest = \req -> do+          req' <- managerModifyRequest settings req+          ctx <- getContext+          propagator <- getGlobalTextMapPropagator+          hdrs <- injectToHeaders propagator ctx (requestHeaders req')+          pure req' {requestHeaders = hdrs}+      }+++{- | Wrap any HTTP request action in a client span. The request is used+to derive the span name and attributes; the continuation receives the+modified request with propagation headers injected.++@+resp <- 'tracedHttpRequest' conf req $ \\req' ->+  Client.httpLbs req' manager+@++Exception-safe: the span is always ended, even if the action throws.++@since 0.2.0.0+-}+tracedHttpRequest+  :: HttpClientInstrumentationConfig+  -> Request+  -> (Request -> IO (Response a))+  -> IO (Response a)+tracedHttpRequest conf req action = do+  tracer <- httpTracerProvider+  hcm <- resolveMetrics conf+  let methodText = T.decodeUtf8 (method req)+      reqSpanName = fromMaybe methodText (requestName conf)+  ctx <- getContext+  s <-+    createSpanWithoutCallStack+      tracer+      ctx+      reqSpanName+      defaultSpanArguments {kind = Client}+  let ctx' = insertSpan s ctx+  tok <- attachContext ctx'++  addRequestAttributes conf s req+  upDownCounterAdd (hcmActive hcm) 1 (metricRequestAttrs req)+  startTs <- getTimestamp++  propagator <- getGlobalTextMapPropagator+  hdrs <- injectToHeaders propagator ctx' (requestHeaders req)+  let req' = req {requestHeaders = hdrs}++  let onError (e :: SomeException) = do+        endTs <- getTimestamp+        upDownCounterAdd (hcmActive hcm) (-1) (metricRequestAttrs req)+        recordErrorMetrics hcm req (timestampNanoseconds startTs) (timestampNanoseconds endTs) e+        let errText = T.pack (show e)+        addAttributes s [(unkey SC.error_type, toAttribute errText)]+        setStatus s (Error errText)+        endSpan s Nothing+        detachContext tok+        throwIO e++  resp <-+    action req' `catch` onError++  endTs <- getTimestamp+  upDownCounterAdd (hcmActive hcm) (-1) (metricRequestAttrs req)+  recordResponseMetrics hcm req (timestampNanoseconds startTs) (timestampNanoseconds endTs) resp+  instrumentResponseOnSpan conf s resp+  endSpan s Nothing+  detachContext tok+  pure resp+++-- | Add request attributes to a span. Does not inject propagation headers.+addRequestAttributes   :: (MonadIO m)   => HttpClientInstrumentationConfig-  -> Context+  -> Span   -> Request-  -> m Request-instrumentRequest conf ctxt req = do-  tracer <- httpTracerProvider-  forM_ (lookupSpan ctxt) $ \s -> do-    let url =-          T.decodeUtf8-            ((if secure req then "https://" else "http://") <> host req <> ":" <> B.pack (show $ port req) <> path req <> queryString req)-    updateName s $ fromMaybe url $ requestName conf+  -> m ()+addRequestAttributes conf s req = do+  let url =+        T.decodeUtf8+          ( (if secure req then "https://" else "http://")+              <> host req+              <> ":"+              <> B.pack (show $ port req)+              <> path req+              <> queryString req+          )+      methodText = T.decodeUtf8 $ method req -    let addStableAttributes = do-          addAttributes-            s-            [ ("http.request.method", toAttribute $ T.decodeUtf8 $ method req)-            , ("url.full", toAttribute url)-            , ("url.path", toAttribute $ T.decodeUtf8 $ path req)-            , ("url.query", toAttribute $ T.decodeUtf8 $ queryString req)-            , ("http.host", toAttribute $ T.decodeUtf8 $ host req)-            , ("url.scheme", toAttribute $ TextAttribute $ if secure req then "https" else "http")-            ,-              ( "network.protocol.version"-              , toAttribute $ case requestVersion req of-                  (HttpVersion major minor) -> T.pack (show major <> "." <> show minor)-              )-            ,-              ( "user_agent.original"-              , toAttribute $ maybe "" T.decodeUtf8 (lookup hUserAgent $ requestHeaders req)-              )-            ]-          addAttributes s-            $ H.fromList-            $ mapMaybe-              (\h -> (\v -> ("http.request.header." <> T.decodeUtf8 (foldedCase h), toAttribute (T.decodeUtf8 v))) <$> lookup h (requestHeaders req))-            $ requestHeadersToRecord conf+  updateName s $ fromMaybe methodText $ requestName conf -        addOldAttributes = do-          addAttributes-            s-            [ ("http.method", toAttribute $ T.decodeUtf8 $ method req)-            , ("http.url", toAttribute url)-            , ("http.target", toAttribute $ T.decodeUtf8 (path req <> queryString req))-            , ("http.host", toAttribute $ T.decodeUtf8 $ host req)-            , ("http.scheme", toAttribute $ TextAttribute $ if secure req then "https" else "http")-            ,-              ( "http.flavor"-              , toAttribute $ case requestVersion req of-                  (HttpVersion major minor) -> T.pack (show major <> "." <> show minor)-              )-            ,-              ( "http.user_agent"-              , toAttribute $ maybe "" T.decodeUtf8 (lookup hUserAgent $ requestHeaders req)-              )+  let addStableAttributes = do+        addAttributes+          s+          [ (unkey SC.http_request_method, toAttribute $ T.decodeUtf8 $ method req)+          , (unkey SC.url_full, toAttribute url)+          , (unkey SC.url_path, toAttribute $ T.decodeUtf8 $ path req)+          , (unkey SC.url_query, toAttribute $ T.decodeUtf8 $ queryString req)+          , (unkey SC.server_address, toAttribute $ T.decodeUtf8 $ host req)+          , (unkey SC.server_port, toAttribute $ port req)+          , (unkey SC.url_scheme, toAttribute $ TextAttribute $ if secure req then "https" else "http")+          , (unkey SC.network_protocol_version, toAttribute $ httpVersionText (requestVersion req))+          , (unkey SC.userAgent_original, toAttribute $ maybe "" T.decodeUtf8 (lookup hUserAgent $ requestHeaders req))+          ]+        addAttributes s+          $ H.fromList+          $ mapMaybe+            (\h -> (\v -> ("http.request.header." <> T.decodeUtf8 (foldedCase h), toAttribute (T.decodeUtf8 v))) <$> lookup h (requestHeaders req))+          $ requestHeadersToRecord conf++      addOldAttributes = do+        addAttributes+          s+          [ (unkey SC.http_method, toAttribute $ T.decodeUtf8 $ method req)+          , (unkey SC.http_url, toAttribute url)+          , (unkey SC.http_target, toAttribute $ T.decodeUtf8 (path req <> queryString req))+          , (unkey SC.http_host, toAttribute $ T.decodeUtf8 $ host req)+          , (unkey SC.http_scheme, toAttribute $ TextAttribute $ if secure req then "https" else "http")+          , (unkey SC.http_flavor, toAttribute $ httpVersionText (requestVersion req))+          , (unkey SC.http_userAgent, toAttribute $ maybe "" T.decodeUtf8 (lookup hUserAgent $ requestHeaders req))+          ]+        addAttributes s+          $ H.fromList+          $ mapMaybe+            (\h -> (\v -> ("http.request.header." <> T.decodeUtf8 (foldedCase h), toAttribute (T.decodeUtf8 v))) <$> lookup h (requestHeaders req))+          $ requestHeadersToRecord conf++  semanticsOptions <- liftIO getSemanticsOptions+  case httpOption semanticsOptions of+    Stable -> addStableAttributes+    StableAndOld -> addStableAttributes >> addOldAttributes+    Old -> addOldAttributes+++-- | Record response attributes on a specific span.+instrumentResponseOnSpan+  :: (MonadIO m)+  => HttpClientInstrumentationConfig+  -> Span+  -> Response a+  -> m ()+instrumentResponseOnSpan conf s resp = do+  let sc = statusCode (responseStatus resp)+      errorAttrs+        | sc >= 400 = [(unkey SC.error_type, toAttribute (T.pack $ show sc))]+        | otherwise = []+      headerAttrs =+        H.fromList+          $ mapMaybe+            (\h -> (\v -> ("http.response.header." <> T.decodeUtf8 (foldedCase h), toAttribute (T.decodeUtf8 v))) <$> lookup h (responseHeaders resp))+          $ responseHeadersToRecord conf++  semanticsOptions <- liftIO getSemanticsOptions+  case httpOption semanticsOptions of+    Stable ->+      addAttributes s $+        H.fromList ((unkey SC.http_response_statusCode, toAttribute sc) : errorAttrs)+          `H.union` headerAttrs+    StableAndOld ->+      addAttributes s $+        H.fromList+          ( [ (unkey SC.http_response_statusCode, toAttribute sc)+            , (unkey SC.http_statusCode, toAttribute sc)             ]-          addAttributes s-            $ H.fromList-            $ mapMaybe-              (\h -> (\v -> ("http.request.header." <> T.decodeUtf8 (foldedCase h), toAttribute (T.decodeUtf8 v))) <$> lookup h (requestHeaders req))-            $ requestHeadersToRecord conf+              <> errorAttrs+          )+          `H.union` headerAttrs+    Old ->+      addAttributes s $+        H.fromList ((unkey SC.http_statusCode, toAttribute sc) : errorAttrs)+          `H.union` headerAttrs -    semanticsOptions <- liftIO getSemanticsOptions-    case httpOption semanticsOptions of-      Stable -> addStableAttributes-      StableAndOld -> addStableAttributes >> addOldAttributes-      Old -> addOldAttributes+  when (sc >= 400) $+    setStatus s (Error "") -  hdrs <- inject (getTracerProviderPropagators $ getTracerTracerProvider tracer) ctxt $ requestHeaders req++{- | Add request attributes and inject propagation headers.++This is the original low-level function. For most use cases, prefer+'instrumentManagerSettings' or 'tracedHttpRequest'.++@since 0.1.0.0+-}+instrumentRequest+  :: (MonadIO m)+  => HttpClientInstrumentationConfig+  -> Ctx.Context+  -> Request+  -> m Request+instrumentRequest conf ctxt req = do+  forM_ (lookupSpan ctxt) $ \s ->+    addRequestAttributes conf s req++  propagator <- liftIO getGlobalTextMapPropagator+  hdrs <- injectToHeaders propagator ctxt $ requestHeaders req   pure $     req       { requestHeaders = hdrs       }  +{- | Record response attributes on the active span in the given context.++This is the original low-level function. For most use cases, prefer+'instrumentManagerSettings' or 'tracedHttpRequest'.++@since 0.1.0.0+-} instrumentResponse   :: (MonadIO m)   => HttpClientInstrumentationConfig-  -> Context+  -> Ctx.Context   -> Response a   -> m () instrumentResponse conf ctxt resp = do-  tracer <- httpTracerProvider-  ctxt' <- extract (getTracerProviderPropagators $ getTracerTracerProvider tracer) (responseHeaders resp) ctxt-  _ <- attachContext ctxt'-  forM_ (lookupSpan ctxt') $ \s -> do-    when (statusCode (responseStatus resp) >= 400) $ do-      setStatus s (Error "")-    let addStableAttributes = do-          addAttributes-            s-            [ ("http.response.statusCode", toAttribute $ statusCode $ responseStatus resp)-            -- TODO-            -- , ("http.request.body.size",	_)-            -- , ("http.request_content_length_uncompressed",	_)-            -- , ("http.response.body.size", _)-            -- , ("http.response_content_length_uncompressed", _)-            -- , ("net.transport")-            -- , ("server.address")-            -- , ("server.port")-            ]-          addAttributes s-            $ H.fromList-            $ mapMaybe-              (\h -> (\v -> ("http.response.header." <> T.decodeUtf8 (foldedCase h), toAttribute (T.decodeUtf8 v))) <$> lookup h (responseHeaders resp))-            $ responseHeadersToRecord conf-        addOldAttributes = do-          addAttributes-            s-            [ ("http.status_code", toAttribute $ statusCode $ responseStatus resp)-            -- TODO-            -- , ("http.request_content_length",	_)-            -- , ("http.request_content_length_uncompressed",	_)-            -- , ("http.response_content_length", _)-            -- , ("http.response_content_length_uncompressed", _)-            -- , ("net.transport")-            -- , ("net.peer.name")-            -- , ("net.peer.ip")-            -- , ("net.peer.port")-            ]-          addAttributes s-            $ H.fromList-            $ mapMaybe-              (\h -> (\v -> ("http.response.header." <> T.decodeUtf8 (foldedCase h), toAttribute (T.decodeUtf8 v))) <$> lookup h (responseHeaders resp))-            $ responseHeadersToRecord conf+  propagator <- liftIO getGlobalTextMapPropagator+  ctxt' <- extractFromHeaders propagator (responseHeaders resp) ctxt+  forM_ (lookupSpan ctxt') $ \s ->+    instrumentResponseOnSpan conf s resp -    semanticsOptions <- liftIO getSemanticsOptions-    case httpOption semanticsOptions of-      Stable -> addStableAttributes-      StableAndOld -> addStableAttributes >> addOldAttributes-      Old -> addOldAttributes++httpVersionText :: HttpVersion -> T.Text+httpVersionText (HttpVersion major minor) =+  TL.toStrict $ toLazyText $ decimal major <> "." <> decimal minor+++headersToTextMap :: RequestHeaders -> TextMap+headersToTextMap = textMapFromList . map (\(k, v) -> (T.decodeUtf8 (foldedCase k), T.decodeUtf8 v))+++injectToHeaders :: (MonadIO m) => TextMapPropagator -> Ctx.Context -> RequestHeaders -> m RequestHeaders+injectToHeaders propagator ctx existingHeaders = do+  tm <- inject propagator ctx (headersToTextMap existingHeaders)+  pure $ map (\(k, v) -> (CI.mk (T.encodeUtf8 k), T.encodeUtf8 v)) (textMapToList tm)+++extractFromHeaders :: (MonadIO m) => TextMapPropagator -> ResponseHeaders -> Ctx.Context -> m Ctx.Context+extractFromHeaders propagator hdrs = extract propagator (headersToTextMap hdrs)

@@ -1,7 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{- | OpenTelemetry instrumentation for @http-conduit@ \/ @Network.HTTP.Simple@.++Provides drop-in replacements for the @http-conduit@ convenience functions.+Zero-config versions use default settings; primed variants accept+'HttpClientInstrumentationConfig'.++For Manager-level instrumentation (recommended for most applications), see+"OpenTelemetry.Instrumentation.HttpClient".+-} module OpenTelemetry.Instrumentation.HttpClient.Simple (+  -- * Zero-config drop-in replacements   httpBS,   httpLBS,   httpNoBody,@@ -10,8 +20,22 @@   httpSink,   httpSource,   withResponse,++  -- * Explicit-config variants+  httpBS',+  httpLBS',+  httpNoBody',+  httpJSON',+  httpJSONEither',+  httpSink',+  httpSource',+  withResponse',++  -- * Configuration   httpClientInstrumentationConfig,   HttpClientInstrumentationConfig (..),++  -- * Re-exports   module X, ) where @@ -34,8 +58,44 @@ spanArgs = defaultSpanArguments {kind = Client}  -httpBS :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response B.ByteString)-httpBS httpConf req = do+-- Zero-config versions++httpBS :: (MonadUnliftIO m, HasCallStack) => Simple.Request -> m (Simple.Response B.ByteString)+httpBS = httpBS' mempty+++httpLBS :: (MonadUnliftIO m, HasCallStack) => Simple.Request -> m (Simple.Response L.ByteString)+httpLBS = httpLBS' mempty+++httpNoBody :: (MonadUnliftIO m, HasCallStack) => Simple.Request -> m (Simple.Response ())+httpNoBody = httpNoBody' mempty+++httpJSON :: (MonadUnliftIO m, FromJSON a, HasCallStack) => Simple.Request -> m (Simple.Response a)+httpJSON = httpJSON' mempty+++httpJSONEither :: (FromJSON a, MonadUnliftIO m, HasCallStack) => Simple.Request -> m (Simple.Response (Either Simple.JSONException a))+httpJSONEither = httpJSONEither' mempty+++httpSink :: (MonadUnliftIO m, HasCallStack) => Simple.Request -> (Simple.Response () -> ConduitM B.ByteString Void m a) -> m a+httpSink = httpSink' mempty+++httpSource :: (MonadUnliftIO m, MonadResource m, HasCallStack) => Simple.Request -> (Simple.Response (ConduitM i B.ByteString m ()) -> ConduitM i o m r) -> ConduitM i o m r+httpSource = httpSource' mempty+++withResponse :: (MonadUnliftIO m, HasCallStack) => Simple.Request -> (Simple.Response (ConduitM i B.ByteString m ()) -> m a) -> m a+withResponse = withResponse' mempty+++-- Explicit-config variants++httpBS' :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response B.ByteString)+httpBS' httpConf req = do   tracer <- httpTracerProvider   inSpan' tracer "httpBS" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do     ctxt <- getContext@@ -45,8 +105,8 @@     pure resp  -httpLBS :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response L.ByteString)-httpLBS httpConf req = do+httpLBS' :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response L.ByteString)+httpLBS' httpConf req = do   tracer <- httpTracerProvider   inSpan' tracer "httpLBS" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do     ctxt <- getContext@@ -56,8 +116,8 @@     pure resp  -httpNoBody :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response ())-httpNoBody httpConf req = do+httpNoBody' :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response ())+httpNoBody' httpConf req = do   tracer <- httpTracerProvider   inSpan' tracer "httpNoBody" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do     ctxt <- getContext@@ -67,8 +127,8 @@     pure resp  -httpJSON :: (MonadUnliftIO m, FromJSON a, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response a)-httpJSON httpConf req = do+httpJSON' :: (MonadUnliftIO m, FromJSON a, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response a)+httpJSON' httpConf req = do   tracer <- httpTracerProvider   inSpan' tracer "httpJSON" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do     ctxt <- getContext@@ -78,8 +138,8 @@     pure resp  -httpJSONEither :: (FromJSON a, MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response (Either Simple.JSONException a))-httpJSONEither httpConf req = do+httpJSONEither' :: (FromJSON a, MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response (Either Simple.JSONException a))+httpJSONEither' httpConf req = do   tracer <- httpTracerProvider   inSpan' tracer "httpJSONEither" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do     ctxt <- getContext@@ -89,8 +149,8 @@     pure resp  -httpSink :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response () -> ConduitM B.ByteString Void m a) -> m a-httpSink httpConf req f = do+httpSink' :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response () -> ConduitM B.ByteString Void m a) -> m a+httpSink' httpConf req f = do   tracer <- httpTracerProvider   inSpan' tracer "httpSink" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do     ctxt <- getContext@@ -100,8 +160,8 @@       f resp  -httpSource :: (MonadUnliftIO m, MonadResource m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response (ConduitM i B.ByteString m ()) -> ConduitM i o m r) -> ConduitM i o m r-httpSource httpConf req f = do+httpSource' :: (MonadUnliftIO m, MonadResource m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response (ConduitM i B.ByteString m ()) -> ConduitM i o m r) -> ConduitM i o m r+httpSource' httpConf req f = do   tracer <- httpTracerProvider   Conduit.inSpan tracer "httpSource" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do     ctxt <- lift getContext@@ -111,8 +171,8 @@       f resp  -withResponse :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response (ConduitM i B.ByteString m ()) -> m a) -> m a-withResponse httpConf req f = do+withResponse' :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response (ConduitM i B.ByteString m ()) -> m a) -> m a+withResponse' httpConf req f = do   tracer <- httpTracerProvider   inSpan' tracer "withResponse" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do     ctxt <- getContext

@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.IORef+import qualified Data.Text as T+import Network.HTTP.Client (parseRequest)+import OpenTelemetry.Attributes (lookupAttribute)+import OpenTelemetry.Attributes.Attribute (Attribute (..), PrimitiveAttribute (..))+import OpenTelemetry.Attributes.Key (unkey)+import qualified OpenTelemetry.Context as Context+import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter)+import OpenTelemetry.Instrumentation.HttpClient.Raw+import qualified OpenTelemetry.SemanticConventions as SC+import OpenTelemetry.Trace.Core+import System.Environment (setEnv)+import Test.Hspec+++main :: IO ()+main = do+  setEnv "OTEL_SEMCONV_STABILITY_OPT_IN" "http"+  hspec spec+++withTestSpan :: T.Text -> (Context.Context -> Span -> IO a) -> IO (ImmutableSpan, a)+withTestSpan name action = do+  (processor, ref) <- inMemoryListExporter+  tp <- createTracerProvider [processor] emptyTracerProviderOptions+  setGlobalTracerProvider tp+  let tracer = makeTracer tp "test" tracerOptions+  s <- createSpan tracer Context.empty name (defaultSpanArguments {kind = Client})+  let ctx = Context.insertSpan s Context.empty+  result <- action ctx s+  endSpan s Nothing+  _ <- shutdownTracerProvider tp Nothing+  spans <- readIORef ref+  case spans of+    (clientSpan : _) -> pure (clientSpan, result)+    [] -> error "No spans recorded"+++spec :: Spec+spec = describe "HTTP client instrumentation" $ do+  describe "instrumentRequest" $ do+    it "sets span name to HTTP method (low cardinality)" $ do+      req <- parseRequest "http://example.com/users/123?q=test"+      (clientSpan, _) <- withTestSpan "HTTP" $ \ctx _s -> do+        _ <- instrumentRequest httpClientInstrumentationConfig ctx req+        pure ()+      hot <- readIORef (spanHot clientSpan)+      hotName hot `shouldBe` "GET"++    it "uses requestName override when provided" $ do+      req <- parseRequest "http://example.com/users/123"+      let conf = httpClientInstrumentationConfig {requestName = Just "custom-op"}+      (clientSpan, _) <- withTestSpan "HTTP" $ \ctx _s -> do+        _ <- instrumentRequest conf ctx req+        pure ()+      hot <- readIORef (spanHot clientSpan)+      hotName hot `shouldBe` "custom-op"++    it "sets http.request.method" $ do+      req <- parseRequest "POST http://example.com/api/data"+      (clientSpan, _) <- withTestSpan "HTTP" $ \ctx _s -> do+        _ <- instrumentRequest httpClientInstrumentationConfig ctx req+        pure ()+      hot <- readIORef (spanHot clientSpan)+      lookupAttribute (hotAttributes hot) (unkey SC.http_request_method)+        `shouldBe` Just (AttributeValue (TextAttribute "POST"))++    it "sets url.path" $ do+      req <- parseRequest "http://example.com/api/data"+      (clientSpan, _) <- withTestSpan "HTTP" $ \ctx _s -> do+        _ <- instrumentRequest httpClientInstrumentationConfig ctx req+        pure ()+      hot <- readIORef (spanHot clientSpan)+      lookupAttribute (hotAttributes hot) (unkey SC.url_path)+        `shouldBe` Just (AttributeValue (TextAttribute "/api/data"))++    it "sets server.address" $ do+      req <- parseRequest "http://example.com/test"+      (clientSpan, _) <- withTestSpan "HTTP" $ \ctx _s -> do+        _ <- instrumentRequest httpClientInstrumentationConfig ctx req+        pure ()+      hot <- readIORef (spanHot clientSpan)+      lookupAttribute (hotAttributes hot) (unkey SC.server_address)+        `shouldBe` Just (AttributeValue (TextAttribute "example.com"))++    it "sets server.port" $ do+      req <- parseRequest "http://example.com:8080/test"+      (clientSpan, _) <- withTestSpan "HTTP" $ \ctx _s -> do+        _ <- instrumentRequest httpClientInstrumentationConfig ctx req+        pure ()+      hot <- readIORef (spanHot clientSpan)+      lookupAttribute (hotAttributes hot) (unkey SC.server_port)+        `shouldBe` Just (AttributeValue (IntAttribute 8080))++    it "sets url.scheme to http" $ do+      req <- parseRequest "http://example.com/test"+      (clientSpan, _) <- withTestSpan "HTTP" $ \ctx _s -> do+        _ <- instrumentRequest httpClientInstrumentationConfig ctx req+        pure ()+      hot <- readIORef (spanHot clientSpan)+      lookupAttribute (hotAttributes hot) (unkey SC.url_scheme)+        `shouldBe` Just (AttributeValue (TextAttribute "http"))