{-# LANGUAGE OverloadedStrings #-}
module OpenTelemetry.Instrumentation.HttpClient (
withResponse,
httpLbs,
httpNoBody,
responseOpen,
httpClientInstrumentationConfig,
HttpClientInstrumentationConfig (..),
module X,
) where
import Control.Monad.IO.Class (MonadIO (..))
import qualified Data.ByteString.Lazy as L
import GHC.Stack
import Network.HTTP.Client as X hiding (httpLbs, httpNoBody, responseOpen, withResponse)
import qualified Network.HTTP.Client as Client
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Instrumentation.HttpClient.Raw (
HttpClientInstrumentationConfig (..),
httpClientInstrumentationConfig,
httpTracerProvider,
instrumentRequest,
instrumentResponse,
)
import OpenTelemetry.Trace.Core (
SpanArguments (kind),
SpanKind (Client),
addAttributesToSpanArguments,
callerAttributes,
defaultSpanArguments,
inSpan'',
)
import UnliftIO (MonadUnliftIO, askRunInIO)
spanArgs :: SpanArguments
spanArgs :: SpanArguments
spanArgs = SpanArguments
defaultSpanArguments {kind = Client}
withResponse
:: (MonadUnliftIO m, HasCallStack)
=> HttpClientInstrumentationConfig
-> Client.Request
-> Client.Manager
-> (Client.Response Client.BodyReader -> m a)
-> m a
withResponse :: forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
HttpClientInstrumentationConfig
-> Request -> Manager -> (Response BodyReader -> m a) -> m a
withResponse HttpClientInstrumentationConfig
httpConf Request
req Manager
man Response BodyReader -> m a
f = do
Tracer
tracer <- m Tracer
forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
tracer Text
"withResponse" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HashMap Text Attribute
HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) ((Span -> m a) -> m a) -> (Span -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Span
_wrSpan -> do
Context
ctxt <- m Context
forall (m :: * -> *). MonadIO m => m Context
getContext
Request
req' <- HttpClientInstrumentationConfig -> Context -> Request -> m Request
forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
m a -> IO a
runInIO <- m (m a -> IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> (Response BodyReader -> IO a) -> IO a
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
Client.withResponse Request
req' Manager
man ((Response BodyReader -> IO a) -> IO a)
-> (Response BodyReader -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Response BodyReader
resp -> do
()
_ <- HttpClientInstrumentationConfig
-> Context -> Response BodyReader -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response BodyReader
resp
m a -> IO a
runInIO (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> m a
f Response BodyReader
resp
httpLbs :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response L.ByteString)
httpLbs :: forall (m :: * -> *).
(MonadUnliftIO m, HasCallStack) =>
HttpClientInstrumentationConfig
-> Request -> Manager -> m (Response ByteString)
httpLbs HttpClientInstrumentationConfig
httpConf Request
req Manager
man = do
Tracer
tracer <- m Tracer
forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
Tracer
-> Text
-> SpanArguments
-> (Span -> m (Response ByteString))
-> m (Response ByteString)
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
tracer Text
"httpLbs" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HashMap Text Attribute
HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) ((Span -> m (Response ByteString)) -> m (Response ByteString))
-> (Span -> m (Response ByteString)) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ \Span
_ -> do
Context
ctxt <- m Context
forall (m :: * -> *). MonadIO m => m Context
getContext
Request
req' <- HttpClientInstrumentationConfig -> Context -> Request -> m Request
forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
Response ByteString
resp <- IO (Response ByteString) -> m (Response ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
Client.httpLbs Request
req' Manager
man
()
_ <- HttpClientInstrumentationConfig
-> Context -> Response ByteString -> m ()
forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response ByteString
resp
Response ByteString -> m (Response ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response ByteString
resp
httpNoBody :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response ())
httpNoBody :: forall (m :: * -> *).
(MonadUnliftIO m, HasCallStack) =>
HttpClientInstrumentationConfig
-> Request -> Manager -> m (Response ())
httpNoBody HttpClientInstrumentationConfig
httpConf Request
req Manager
man = do
Tracer
tracer <- m Tracer
forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
Tracer
-> Text
-> SpanArguments
-> (Span -> m (Response ()))
-> m (Response ())
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
tracer Text
"httpNoBody" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HashMap Text Attribute
HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) ((Span -> m (Response ())) -> m (Response ()))
-> (Span -> m (Response ())) -> m (Response ())
forall a b. (a -> b) -> a -> b
$ \Span
_ -> do
Context
ctxt <- m Context
forall (m :: * -> *). MonadIO m => m Context
getContext
Request
req' <- HttpClientInstrumentationConfig -> Context -> Request -> m Request
forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
Response ()
resp <- IO (Response ()) -> m (Response ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ()) -> m (Response ()))
-> IO (Response ()) -> m (Response ())
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ())
Client.httpNoBody Request
req' Manager
man
()
_ <- HttpClientInstrumentationConfig -> Context -> Response () -> m ()
forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response ()
resp
Response () -> m (Response ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response ()
resp
responseOpen :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response Client.BodyReader)
responseOpen :: forall (m :: * -> *).
(MonadUnliftIO m, HasCallStack) =>
HttpClientInstrumentationConfig
-> Request -> Manager -> m (Response BodyReader)
responseOpen HttpClientInstrumentationConfig
httpConf Request
req Manager
man = do
Tracer
tracer <- m Tracer
forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
Tracer
-> Text
-> SpanArguments
-> (Span -> m (Response BodyReader))
-> m (Response BodyReader)
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
tracer Text
"responseOpen" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HashMap Text Attribute
HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) ((Span -> m (Response BodyReader)) -> m (Response BodyReader))
-> (Span -> m (Response BodyReader)) -> m (Response BodyReader)
forall a b. (a -> b) -> a -> b
$ \Span
_ -> do
Context
ctxt <- m Context
forall (m :: * -> *). MonadIO m => m Context
getContext
Request
req' <- HttpClientInstrumentationConfig -> Context -> Request -> m Request
forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
Response BodyReader
resp <- IO (Response BodyReader) -> m (Response BodyReader)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response BodyReader) -> m (Response BodyReader))
-> IO (Response BodyReader) -> m (Response BodyReader)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response BodyReader)
Client.responseOpen Request
req' Manager
man
()
_ <- HttpClientInstrumentationConfig
-> Context -> Response BodyReader -> m ()
forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response BodyReader
resp
Response BodyReader -> m (Response BodyReader)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response BodyReader
resp