diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Ian Duncan (c) 2021 +Copyright Ian Duncan (c) 2021-2026 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/hs-opentelemetry-instrumentation-http-client.cabal b/hs-opentelemetry-instrumentation-http-client.cabal --- a/hs-opentelemetry-instrumentation-http-client.cabal +++ b/hs-opentelemetry-instrumentation-http-client.cabal @@ -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 -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 +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 diff --git a/src/OpenTelemetry/Instrumentation/HttpClient.hs b/src/OpenTelemetry/Instrumentation/HttpClient.hs --- a/src/OpenTelemetry/Instrumentation/HttpClient.hs +++ b/src/OpenTelemetry/Instrumentation/HttpClient.hs @@ -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 diff --git a/src/OpenTelemetry/Instrumentation/HttpClient/Raw.hs b/src/OpenTelemetry/Instrumentation/HttpClient/Raw.hs --- a/src/OpenTelemetry/Instrumentation/HttpClient/Raw.hs +++ b/src/OpenTelemetry/Instrumentation/HttpClient/Raw.hs @@ -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) diff --git a/src/OpenTelemetry/Instrumentation/HttpClient/Simple.hs b/src/OpenTelemetry/Instrumentation/HttpClient/Simple.hs --- a/src/OpenTelemetry/Instrumentation/HttpClient/Simple.hs +++ b/src/OpenTelemetry/Instrumentation/HttpClient/Simple.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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"))