hs-opentelemetry-instrumentation-http-client 0.1.0.0 → 0.1.0.1
raw patch · 6 files changed
+144/−107 lines, 6 filesdep −hs-opentelemetry-instrumentation-http-clientdep −http-client-tlsdep ~hs-opentelemetry-apinew-uploader
Dependencies removed: hs-opentelemetry-instrumentation-http-client, http-client-tls
Dependency ranges changed: hs-opentelemetry-api
Files
- ChangeLog.md +3/−1
- hs-opentelemetry-instrumentation-http-client.cabal +4/−31
- src/OpenTelemetry/Instrumentation/HttpClient.hs +13/−8
- src/OpenTelemetry/Instrumentation/HttpClient/Raw.hs +107/−48
- src/OpenTelemetry/Instrumentation/HttpClient/Simple.hs +17/−16
- test/Spec.hs +0/−3
ChangeLog.md view
@@ -1,6 +1,8 @@ # Changelog for hs-opentelemetry-instrumentation-http-client -## Unreleased changes+## 0.1.0.1++- Support newer dependencies ## 0.1.0.0
hs-opentelemetry-instrumentation-http-client.cabal view
@@ -1,17 +1,17 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: hs-opentelemetry-instrumentation-http-client-version: 0.1.0.0+version: 0.1.0.1 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: 2023 Ian Duncan, Mercury Technologies+copyright: 2024 Ian Duncan, Mercury Technologies license: BSD3 license-file: LICENSE build-type: Simple@@ -39,36 +39,9 @@ , bytestring , case-insensitive , conduit- , hs-opentelemetry-api ==0.1.*+ , hs-opentelemetry-api ==0.2.* , hs-opentelemetry-instrumentation-conduit >=0.0.1 && <0.2 , http-client- , http-client-tls- , 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:- aeson- , base >=4.7 && <5- , bytestring- , case-insensitive- , conduit- , hs-opentelemetry-api ==0.1.*- , hs-opentelemetry-instrumentation-conduit >=0.0.1 && <0.2- , hs-opentelemetry-instrumentation-http-client- , http-client- , http-client-tls , http-conduit , http-types , text
src/OpenTelemetry/Instrumentation/HttpClient.hs view
@@ -6,6 +6,11 @@ - 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)++[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. -} module OpenTelemetry.Instrumentation.HttpClient ( withResponse,@@ -68,8 +73,8 @@ -> (Client.Response Client.BodyReader -> m a) -> m a withResponse httpConf req man f = do- t <- httpTracerProvider- inSpan'' t "withResponse" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_wrSpan -> 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@@ -88,8 +93,8 @@ -} httpLbs :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response L.ByteString) httpLbs httpConf req man = do- t <- httpTracerProvider- inSpan'' t "httpLbs" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_ -> do+ tracer <- httpTracerProvider+ inSpan'' tracer "httpLbs" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_ -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req resp <- liftIO $ Client.httpLbs req' man@@ -102,8 +107,8 @@ -} httpNoBody :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response ()) httpNoBody httpConf req man = do- t <- httpTracerProvider- inSpan'' t "httpNoBody" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_ -> do+ tracer <- httpTracerProvider+ inSpan'' tracer "httpNoBody" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_ -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req resp <- liftIO $ Client.httpNoBody req' man@@ -141,8 +146,8 @@ -} responseOpen :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response Client.BodyReader) responseOpen httpConf req man = do- t <- httpTracerProvider- inSpan'' t "responseOpen" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_ -> do+ tracer <- httpTracerProvider+ inSpan'' tracer "responseOpen" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_ -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req resp <- liftIO $ Client.responseOpen req' man
src/OpenTelemetry/Instrumentation/HttpClient/Raw.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module OpenTelemetry.Instrumentation.HttpClient.Raw where @@ -9,8 +10,7 @@ import qualified Data.ByteString.Char8 as B import Data.CaseInsensitive (foldedCase) import qualified Data.HashMap.Strict as H-import Data.Maybe (mapMaybe)-import qualified Data.Maybe+import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Client@@ -18,6 +18,7 @@ import OpenTelemetry.Context (Context, lookupSpan) import OpenTelemetry.Context.ThreadLocal import OpenTelemetry.Propagator+import OpenTelemetry.SemanticsConfig import OpenTelemetry.Trace.Core @@ -54,7 +55,7 @@ httpTracerProvider :: (MonadIO m) => m Tracer httpTracerProvider = do tp <- getGlobalTracerProvider- pure $ makeTracer tp "hs-opentelemetry-instrumentation-http-client" tracerOptions+ pure $ makeTracer tp $detectInstrumentationLibrary tracerOptions instrumentRequest@@ -64,36 +65,69 @@ -> Request -> m Request instrumentRequest conf ctxt req = do- tp <- httpTracerProvider+ 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 $ Data.Maybe.fromMaybe url $ requestName conf- 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)- )- ]- 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 url $ requestName conf - hdrs <- inject (getTracerProviderPropagators $ getTracerTracerProvider tp) ctxt $ requestHeaders 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++ 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)+ )+ ]+ 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++ hdrs <- inject (getTracerProviderPropagators $ getTracerTracerProvider tracer) ctxt $ requestHeaders req pure $ req { requestHeaders = hdrs@@ -107,27 +141,52 @@ -> Response a -> m () instrumentResponse conf ctxt resp = do- tp <- httpTracerProvider- ctxt' <- extract (getTracerProviderPropagators $ getTracerTracerProvider tp) (responseHeaders resp) ctxt+ 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 "")- 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+ 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++ semanticsOptions <- liftIO getSemanticsOptions+ case httpOption semanticsOptions of+ Stable -> addStableAttributes+ StableAndOld -> addStableAttributes >> addOldAttributes+ Old -> addOldAttributes
src/OpenTelemetry/Instrumentation/HttpClient/Simple.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module OpenTelemetry.Instrumentation.HttpClient.Simple ( httpBS,@@ -35,8 +36,8 @@ httpBS :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response B.ByteString) httpBS httpConf req = do- t <- httpTracerProvider- inSpan' t "httpBS" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do+ tracer <- httpTracerProvider+ inSpan' tracer "httpBS" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req resp <- Simple.httpBS req'@@ -46,8 +47,8 @@ httpLBS :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response L.ByteString) httpLBS httpConf req = do- t <- httpTracerProvider- inSpan' t "httpLBS" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do+ tracer <- httpTracerProvider+ inSpan' tracer "httpLBS" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req resp <- Simple.httpLBS req'@@ -57,8 +58,8 @@ httpNoBody :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response ()) httpNoBody httpConf req = do- t <- httpTracerProvider- inSpan' t "httpNoBody" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do+ tracer <- httpTracerProvider+ inSpan' tracer "httpNoBody" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req resp <- Simple.httpNoBody req'@@ -68,8 +69,8 @@ httpJSON :: (MonadUnliftIO m, FromJSON a, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response a) httpJSON httpConf req = do- t <- httpTracerProvider- inSpan' t "httpJSON" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do+ tracer <- httpTracerProvider+ inSpan' tracer "httpJSON" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req resp <- Simple.httpJSON req'@@ -79,8 +80,8 @@ httpJSONEither :: (FromJSON a, MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response (Either Simple.JSONException a)) httpJSONEither httpConf req = do- t <- httpTracerProvider- inSpan' t "httpJSONEither" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do+ tracer <- httpTracerProvider+ inSpan' tracer "httpJSONEither" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req resp <- Simple.httpJSONEither req'@@ -90,8 +91,8 @@ httpSink :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response () -> ConduitM B.ByteString Void m a) -> m a httpSink httpConf req f = do- t <- httpTracerProvider- inSpan' t "httpSink" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do+ tracer <- httpTracerProvider+ inSpan' tracer "httpSink" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req Simple.httpSink req' $ \resp -> do@@ -101,8 +102,8 @@ 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- t <- httpTracerProvider- Conduit.inSpan t "httpSource" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do+ tracer <- httpTracerProvider+ Conduit.inSpan tracer "httpSource" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do ctxt <- lift getContext req' <- instrumentRequest httpConf ctxt req Simple.httpSource req' $ \resp -> do@@ -112,8 +113,8 @@ withResponse :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response (ConduitM i B.ByteString m ()) -> m a) -> m a withResponse httpConf req f = do- t <- httpTracerProvider- inSpan' t "withResponse" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do+ tracer <- httpTracerProvider+ inSpan' tracer "withResponse" (addAttributesToSpanArguments callerAttributes spanArgs) $ \_s -> do ctxt <- getContext req' <- instrumentRequest httpConf ctxt req Simple.withResponse req' $ \resp -> do
− test/Spec.hs
@@ -1,3 +0,0 @@--main :: IO ()-main = putStrLn "Test suite not yet implemented"