{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module OpenTelemetry.Instrumentation.HttpClient.Simple ( httpBS, httpLBS, httpNoBody, httpJSON, httpJSONEither, httpSink, httpSource, withResponse, httpClientInstrumentationConfig, HttpClientInstrumentationConfig (..), module X, ) where import Conduit (MonadResource, lift) import Data.Aeson (FromJSON) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Conduit (ConduitM, Void) import GHC.Stack import Network.HTTP.Simple as X hiding (httpBS, httpJSON, httpJSONEither, httpLBS, httpNoBody, httpSink, httpSource, withResponse) import qualified Network.HTTP.Simple as Simple import OpenTelemetry.Context.ThreadLocal import qualified OpenTelemetry.Instrumentation.Conduit as Conduit import OpenTelemetry.Instrumentation.HttpClient.Raw import OpenTelemetry.Trace.Core import UnliftIO spanArgs :: SpanArguments spanArgs :: SpanArguments spanArgs = SpanArguments defaultSpanArguments {kind = Client} httpBS :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response B.ByteString) httpBS :: forall (m :: * -> *). (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Request -> m (Response ByteString) httpBS HttpClientInstrumentationConfig httpConf Request req = 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 "httpBS" (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 _s -> 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 <- Request -> m (Response ByteString) forall (m :: * -> *). MonadIO m => Request -> m (Response ByteString) Simple.httpBS Request req' () _ <- 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 httpLBS :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response L.ByteString) httpLBS :: forall (m :: * -> *). (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Request -> m (Response ByteString) httpLBS HttpClientInstrumentationConfig httpConf Request req = 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 _s -> 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 <- Request -> m (Response ByteString) forall (m :: * -> *). MonadIO m => Request -> m (Response ByteString) Simple.httpLBS Request req' () _ <- 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 -> Simple.Request -> m (Simple.Response ()) httpNoBody :: forall (m :: * -> *). (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Request -> m (Response ()) httpNoBody HttpClientInstrumentationConfig httpConf Request req = 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 _s -> 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 <- Request -> m (Response ()) forall (m :: * -> *). MonadIO m => Request -> m (Response ()) Simple.httpNoBody Request req' () _ <- 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 httpJSON :: (MonadUnliftIO m, FromJSON a, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response a) httpJSON :: forall (m :: * -> *) a. (MonadUnliftIO m, FromJSON a, HasCallStack) => HttpClientInstrumentationConfig -> Request -> m (Response a) httpJSON HttpClientInstrumentationConfig httpConf Request req = do Tracer tracer <- m Tracer forall (m :: * -> *). MonadIO m => m Tracer httpTracerProvider Tracer -> Text -> SpanArguments -> (Span -> m (Response a)) -> m (Response a) forall (m :: * -> *) a. (MonadUnliftIO m, HasCallStack) => Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a inSpan' Tracer tracer Text "httpJSON" (HashMap Text Attribute -> SpanArguments -> SpanArguments addAttributesToSpanArguments HashMap Text Attribute HasCallStack => HashMap Text Attribute callerAttributes SpanArguments spanArgs) ((Span -> m (Response a)) -> m (Response a)) -> (Span -> m (Response a)) -> m (Response a) forall a b. (a -> b) -> a -> b $ \Span _s -> 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 a resp <- Request -> m (Response a) forall (m :: * -> *) a. (MonadIO m, FromJSON a) => Request -> m (Response a) Simple.httpJSON Request req' () _ <- HttpClientInstrumentationConfig -> Context -> Response a -> m () forall (m :: * -> *) a. MonadIO m => HttpClientInstrumentationConfig -> Context -> Response a -> m () instrumentResponse HttpClientInstrumentationConfig httpConf Context ctxt Response a resp Response a -> m (Response a) forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure Response a resp httpJSONEither :: (FromJSON a, MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> m (Simple.Response (Either Simple.JSONException a)) httpJSONEither :: forall a (m :: * -> *). (FromJSON a, MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Request -> m (Response (Either JSONException a)) httpJSONEither HttpClientInstrumentationConfig httpConf Request req = do Tracer tracer <- m Tracer forall (m :: * -> *). MonadIO m => m Tracer httpTracerProvider Tracer -> Text -> SpanArguments -> (Span -> m (Response (Either JSONException a))) -> m (Response (Either JSONException a)) forall (m :: * -> *) a. (MonadUnliftIO m, HasCallStack) => Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a inSpan' Tracer tracer Text "httpJSONEither" (HashMap Text Attribute -> SpanArguments -> SpanArguments addAttributesToSpanArguments HashMap Text Attribute HasCallStack => HashMap Text Attribute callerAttributes SpanArguments spanArgs) ((Span -> m (Response (Either JSONException a))) -> m (Response (Either JSONException a))) -> (Span -> m (Response (Either JSONException a))) -> m (Response (Either JSONException a)) forall a b. (a -> b) -> a -> b $ \Span _s -> 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 (Either JSONException a) resp <- Request -> m (Response (Either JSONException a)) forall (m :: * -> *) a. (MonadIO m, FromJSON a) => Request -> m (Response (Either JSONException a)) Simple.httpJSONEither Request req' () _ <- HttpClientInstrumentationConfig -> Context -> Response (Either JSONException a) -> m () forall (m :: * -> *) a. MonadIO m => HttpClientInstrumentationConfig -> Context -> Response a -> m () instrumentResponse HttpClientInstrumentationConfig httpConf Context ctxt Response (Either JSONException a) resp Response (Either JSONException a) -> m (Response (Either JSONException a)) forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure Response (Either JSONException a) resp httpSink :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response () -> ConduitM B.ByteString Void m a) -> m a httpSink :: forall (m :: * -> *) a. (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Request -> (Response () -> ConduitM ByteString Void m a) -> m a httpSink HttpClientInstrumentationConfig httpConf Request req Response () -> ConduitM ByteString Void 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 "httpSink" (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 _s -> 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 Request -> (Response () -> ConduitM ByteString Void m a) -> m a forall (m :: * -> *) a. MonadUnliftIO m => Request -> (Response () -> ConduitM ByteString Void m a) -> m a Simple.httpSink Request req' ((Response () -> ConduitM ByteString Void m a) -> m a) -> (Response () -> ConduitM ByteString Void m a) -> m a forall a b. (a -> b) -> a -> b $ \Response () resp -> do () _ <- HttpClientInstrumentationConfig -> Context -> Response () -> ConduitT ByteString Void m () forall (m :: * -> *) a. MonadIO m => HttpClientInstrumentationConfig -> Context -> Response a -> m () instrumentResponse HttpClientInstrumentationConfig httpConf Context ctxt Response () resp Response () -> ConduitM ByteString Void m a f Response () 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 :: forall (m :: * -> *) i o r. (MonadUnliftIO m, MonadResource m, HasCallStack) => HttpClientInstrumentationConfig -> Request -> (Response (ConduitM i ByteString m ()) -> ConduitM i o m r) -> ConduitM i o m r httpSource HttpClientInstrumentationConfig httpConf Request req Response (ConduitM i ByteString m ()) -> ConduitM i o m r f = do Tracer tracer <- ConduitT i o m Tracer forall (m :: * -> *). MonadIO m => m Tracer httpTracerProvider Tracer -> Text -> SpanArguments -> (Span -> ConduitM i o m r) -> ConduitM i o m r forall (m :: * -> *) i o a. (MonadResource m, MonadUnliftIO m, HasCallStack) => Tracer -> Text -> SpanArguments -> (Span -> ConduitM i o m a) -> ConduitM i o m a Conduit.inSpan Tracer tracer Text "httpSource" (HashMap Text Attribute -> SpanArguments -> SpanArguments addAttributesToSpanArguments HashMap Text Attribute HasCallStack => HashMap Text Attribute callerAttributes SpanArguments spanArgs) ((Span -> ConduitM i o m r) -> ConduitM i o m r) -> (Span -> ConduitM i o m r) -> ConduitM i o m r forall a b. (a -> b) -> a -> b $ \Span _s -> do Context ctxt <- m Context -> ConduitT i o m Context forall (m :: * -> *) a. Monad m => m a -> ConduitT i o m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift m Context forall (m :: * -> *). MonadIO m => m Context getContext Request req' <- HttpClientInstrumentationConfig -> Context -> Request -> ConduitT i o m Request forall (m :: * -> *). MonadIO m => HttpClientInstrumentationConfig -> Context -> Request -> m Request instrumentRequest HttpClientInstrumentationConfig httpConf Context ctxt Request req Request -> (Response (ConduitM i ByteString m ()) -> ConduitM i o m r) -> ConduitM i o m r forall (m :: * -> *) (n :: * -> *) i o r. (MonadResource m, MonadIO n) => Request -> (Response (ConduitM i ByteString n ()) -> ConduitM i o m r) -> ConduitM i o m r Simple.httpSource Request req' ((Response (ConduitM i ByteString m ()) -> ConduitM i o m r) -> ConduitM i o m r) -> (Response (ConduitM i ByteString m ()) -> ConduitM i o m r) -> ConduitM i o m r forall a b. (a -> b) -> a -> b $ \Response (ConduitM i ByteString m ()) resp -> do () _ <- HttpClientInstrumentationConfig -> Context -> Response (ConduitM i ByteString m ()) -> ConduitT i o m () forall (m :: * -> *) a. MonadIO m => HttpClientInstrumentationConfig -> Context -> Response a -> m () instrumentResponse HttpClientInstrumentationConfig httpConf Context ctxt Response (ConduitM i ByteString m ()) resp Response (ConduitM i ByteString m ()) -> ConduitM i o m r f Response (ConduitM i ByteString m ()) resp withResponse :: (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Simple.Request -> (Simple.Response (ConduitM i B.ByteString m ()) -> m a) -> m a withResponse :: forall (m :: * -> *) i a. (MonadUnliftIO m, HasCallStack) => HttpClientInstrumentationConfig -> Request -> (Response (ConduitM i ByteString m ()) -> m a) -> m a withResponse HttpClientInstrumentationConfig httpConf Request req Response (ConduitM i ByteString m ()) -> 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 _s -> 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 Request -> (Response (ConduitM i ByteString m ()) -> m a) -> m a forall (m :: * -> *) (n :: * -> *) i a. (MonadUnliftIO m, MonadIO n) => Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a Simple.withResponse Request req' ((Response (ConduitM i ByteString m ()) -> m a) -> m a) -> (Response (ConduitM i ByteString m ()) -> m a) -> m a forall a b. (a -> b) -> a -> b $ \Response (ConduitM i ByteString m ()) resp -> do () _ <- HttpClientInstrumentationConfig -> Context -> Response (ConduitM i ByteString m ()) -> m () forall (m :: * -> *) a. MonadIO m => HttpClientInstrumentationConfig -> Context -> Response a -> m () instrumentResponse HttpClientInstrumentationConfig httpConf Context ctxt Response (ConduitM i ByteString m ()) resp Response (ConduitM i ByteString m ()) -> m a f Response (ConduitM i ByteString m ()) resp