hs-opentelemetry-instrumentation-http-client (empty) → 0.0.1.1

raw patch · 9 files changed

+464/−0 lines, 9 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, case-insensitive, conduit, hs-opentelemetry-api, hs-opentelemetry-instrumentation-conduit, hs-opentelemetry-instrumentation-http-client, http-client, http-client-tls, http-conduit, http-types, text, unliftio

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• hs-opentelemetry-instrumentation-http-client.cabal +75/−0
• src/OpenTelemetry/Instrumentation/HttpClient.hs +133/−0
• src/OpenTelemetry/Instrumentation/HttpClient/Raw.hs +109/−0
• src/OpenTelemetry/Instrumentation/HttpClient/Simple.hs +109/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,3 @@+# Changelog for hs-opentelemetry-instrumentation-http-client++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ian Duncan nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,1 @@+# hs-opentelemetry-instrumentation-http-client

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,75 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           hs-opentelemetry-instrumentation-http-client+version:        0.0.1.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+maintainer:     ian@iankduncan.com+copyright:      2021 Ian Duncan+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/iand675/hs-opentelemetry++library+  exposed-modules:+      OpenTelemetry.Instrumentation.HttpClient+      OpenTelemetry.Instrumentation.HttpClient.Raw+      OpenTelemetry.Instrumentation.HttpClient.Simple+  other-modules:+      Paths_hs_opentelemetry_instrumentation_http_client+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , case-insensitive+    , conduit+    , hs-opentelemetry-api ==0.0.3.*+    , hs-opentelemetry-instrumentation-conduit ==0.0.1.*+    , http-client+    , http-client-tls+    , http-conduit+    , http-types+    , text+    , unliftio+  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.0.3.*+    , hs-opentelemetry-instrumentation-conduit ==0.0.1.*+    , hs-opentelemetry-instrumentation-http-client+    , http-client+    , http-client-tls+    , http-conduit+    , http-types+    , text+    , unliftio+  default-language: Haskell2010

@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}+{- | Offer a few options for HTTP instrumentation++- 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)+-}+module OpenTelemetry.Instrumentation.HttpClient +  ( withResponse+  , httpLbs+  , httpNoBody+  , responseOpen+  , httpClientInstrumentationConfig+  , HttpClientInstrumentationConfig(..)+  , module X+  ) where+import qualified Data.ByteString.Lazy as L+import Control.Monad.IO.Class ( MonadIO(..) )+import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Trace.Core+    ( defaultSpanArguments,+      SpanArguments(kind),+      SpanKind(Client),+      inSpan',+    )++import Network.HTTP.Client as X hiding (withResponse, httpLbs, httpNoBody, responseOpen)+import qualified Network.HTTP.Client as Client+import OpenTelemetry.Instrumentation.HttpClient.Raw+    ( HttpClientInstrumentationConfig(..),+      instrumentRequest,+      instrumentResponse, httpClientInstrumentationConfig, httpTracerProvider )+import UnliftIO ( MonadUnliftIO, askRunInIO )++spanArgs :: SpanArguments+spanArgs = defaultSpanArguments { kind = Client }++-- | Instrumented variant of @Network.HTTP.Client.withResponse@+--+-- 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:+--+-- > 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'.+--+-- You will need to use functions such as 'brRead' to consume the response+-- body.+withResponse :: (MonadUnliftIO m) => HttpClientInstrumentationConfig+             -> Client.Request+             -> Client.Manager+             -> (Client.Response Client.BodyReader -> m a)+             -> m a+withResponse httpConf req man f = do+  t <- httpTracerProvider+  inSpan' t "withResponse" 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+      _ <- instrumentResponse httpConf ctxt resp+      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.+httpLbs :: (MonadUnliftIO m) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response L.ByteString)+httpLbs httpConf req man = do+  t <- httpTracerProvider+  inSpan' t "httpLbs" spanArgs $ \_ -> do+    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    resp <- liftIO $ Client.httpLbs req' man+    _ <- instrumentResponse httpConf ctxt resp+    pure resp+++-- | A convenient wrapper around 'withResponse' which ignores the response+-- body. This is useful, for example, when performing a HEAD request.+httpNoBody :: (MonadUnliftIO m) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response ())+httpNoBody httpConf req man = do+  t <- httpTracerProvider+  inSpan' t "httpNoBody" spanArgs $ \_ -> do+    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    resp <- liftIO $ Client.httpNoBody req' man+    _ <- instrumentResponse httpConf ctxt resp+    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.+--+-- 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.+responseOpen :: (MonadUnliftIO m) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response Client.BodyReader)+responseOpen httpConf req man = do+  t <- httpTracerProvider+  inSpan' t "responseOpen" spanArgs $ \_ -> do+    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    resp <- liftIO $ Client.responseOpen req' man+    _ <-instrumentResponse httpConf ctxt resp+    pure resp

@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}+module OpenTelemetry.Instrumentation.HttpClient.Raw where+import Control.Monad.IO.Class+import OpenTelemetry.Context (Context, lookupSpan)+import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Trace.Core+import OpenTelemetry.Propagator+import Network.HTTP.Client+import Network.HTTP.Types+import Control.Monad (forM_, when)+import qualified Data.ByteString.Char8 as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Foldable (Foldable(toList))+import Data.CaseInsensitive (foldedCase)++data HttpClientInstrumentationConfig = HttpClientInstrumentationConfig+  { requestHeadersToRecord :: [HeaderName]+  , responseHeadersToRecord :: [HeaderName]+  }++instance Semigroup HttpClientInstrumentationConfig where+  l <> r = HttpClientInstrumentationConfig+    { requestHeadersToRecord = requestHeadersToRecord l <> requestHeadersToRecord r+    , responseHeadersToRecord = responseHeadersToRecord l <> responseHeadersToRecord r+    }++instance Monoid HttpClientInstrumentationConfig where+  mempty = HttpClientInstrumentationConfig+    { requestHeadersToRecord = mempty+    , responseHeadersToRecord = mempty+    }++httpClientInstrumentationConfig :: HttpClientInstrumentationConfig+httpClientInstrumentationConfig = mempty++  -- TODO see if we can avoid recreating this on each request without being more invasive with the interface+httpTracerProvider :: MonadIO m => m Tracer+httpTracerProvider = do+  tp <- getGlobalTracerProvider+  pure $ makeTracer tp "hs-opentelemetry-instrumentation-http-client" tracerOptions++instrumentRequest+  :: MonadIO m+  => HttpClientInstrumentationConfig+  -> Context+  -> Request+  -> m Request+instrumentRequest conf ctxt req = do+  tp <- httpTracerProvider+  forM_ (lookupSpan ctxt) $ \s -> do+    addAttributes s+      [ ( "http.method", toAttribute $ T.decodeUtf8 $ method req)+      , ( "http.url",+          toAttribute $+          T.decodeUtf8+          ((if secure req then "https://" else "http://") <> host req <> ":" <> B.pack (show $ port req) <> path req <> queryString req)+        )+      , ( "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 $+      concatMap+        (\h -> toList $ (\v -> ("http.request.header." <> T.decodeUtf8 (foldedCase h), toAttribute (T.decodeUtf8 v))) <$> lookup h (requestHeaders req)) $+        requestHeadersToRecord conf++  hdrs <- inject (getTracerProviderPropagators $ getTracerTracerProvider tp) ctxt $ requestHeaders req+  pure $ req+    { requestHeaders = hdrs+    }+++instrumentResponse+  :: MonadIO m+  => HttpClientInstrumentationConfig+  -> Context+  -> Response a+  -> m ()+instrumentResponse conf ctxt resp = do+  tp <- httpTracerProvider+  ctxt' <- extract (getTracerProviderPropagators $ getTracerTracerProvider tp) (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 $+      concatMap+        (\h -> toList $ (\v -> ("http.response.header." <> T.decodeUtf8 (foldedCase h), toAttribute (T.decodeUtf8 v))) <$> lookup h (responseHeaders resp)) $+        responseHeadersToRecord conf

@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}+module OpenTelemetry.Instrumentation.HttpClient.Simple +  ( httpBS+  , httpLBS+  , httpNoBody+  , httpJSON+  , httpJSONEither+  , httpSink+  , httpSource+  , withResponse+  , httpClientInstrumentationConfig+  , HttpClientInstrumentationConfig(..)+  , module X+  ) where+import qualified Network.HTTP.Simple as Simple+import Network.HTTP.Simple as X hiding (httpBS, httpLBS, httpNoBody, httpJSON, httpJSONEither, httpSink, httpSource, withResponse)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Conduit (ConduitM, Void)+import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Trace.Core+import OpenTelemetry.Instrumentation.HttpClient.Raw+import qualified OpenTelemetry.Instrumentation.Conduit as Conduit+import UnliftIO+import Data.Aeson (FromJSON)+import Conduit (MonadResource, lift)++spanArgs :: SpanArguments+spanArgs = defaultSpanArguments { kind = Client }++httpBS :: (MonadUnliftIO m) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response B.ByteString)+httpBS httpConf req = do+  t <- httpTracerProvider+  inSpan' t "httpBS" spanArgs $ \_s -> do+    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    resp <- Simple.httpBS req'+    _ <- instrumentResponse httpConf ctxt resp+    pure resp++httpLBS :: (MonadUnliftIO m) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response L.ByteString)+httpLBS httpConf req = do+  t <- httpTracerProvider+  inSpan' t "httpLBS" spanArgs $ \_s -> do+    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    resp <- Simple.httpLBS req'+    _ <- instrumentResponse httpConf ctxt resp+    pure resp++httpNoBody :: (MonadUnliftIO m) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response ())+httpNoBody httpConf req = do+  t <- httpTracerProvider+  inSpan' t "httpNoBody" spanArgs $ \_s -> do+    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    resp <- Simple.httpNoBody req'+    _ <- instrumentResponse httpConf ctxt resp+    pure resp++httpJSON :: (MonadUnliftIO m, FromJSON a) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response a)+httpJSON httpConf req = do+  t <- httpTracerProvider+  inSpan' t "httpJSON" spanArgs $ \_s -> do+    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    resp <- Simple.httpJSON req'+    _ <- instrumentResponse httpConf ctxt resp+    pure resp++httpJSONEither :: (FromJSON a, MonadUnliftIO m) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response (Either Simple.JSONException a))+httpJSONEither httpConf req = do+  t <- httpTracerProvider+  inSpan' t "httpJSONEither" spanArgs $ \_s -> do+    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    resp <- Simple.httpJSONEither req'+    _ <- instrumentResponse httpConf ctxt resp+    pure resp++httpSink :: (MonadUnliftIO m) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response () -> ConduitM B.ByteString Void m a) -> m a+httpSink httpConf req f = do+  t <- httpTracerProvider+  inSpan' t "httpSink" spanArgs $ \_s -> do +    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    Simple.httpSink req' $ \resp -> do+      _ <- instrumentResponse httpConf ctxt resp+      f resp++httpSource :: (MonadUnliftIO m, MonadResource m) => 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" spanArgs $ \_s -> do+    ctxt <- lift getContext+    req' <- instrumentRequest httpConf ctxt req+    Simple.httpSource req' $ \resp -> do+      _ <- instrumentResponse httpConf ctxt resp+      f resp++withResponse :: (MonadUnliftIO m) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response (ConduitM i B.ByteString m ()) -> m a) -> m a+withResponse httpConf req f = do+  t <- httpTracerProvider+  inSpan' t "withResponse" spanArgs $ \_s -> do+    ctxt <- getContext+    req' <- instrumentRequest httpConf ctxt req+    Simple.withResponse req' $ \resp -> do+      _ <- instrumentResponse httpConf ctxt resp+      f resp

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"