{-# LANGUAGE OverloadedStrings #-}

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 :: SpanKind
kind = SpanKind
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
t <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
t Text
"httpBS" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
    Context
ctxt <- forall (m :: * -> *). MonadIO m => m Context
getContext
    Request
req' <- forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
    Response ByteString
resp <- forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
Simple.httpBS Request
req'
    ()
_ <- forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response ByteString
resp
    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
t <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
t Text
"httpLBS" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
    Context
ctxt <- forall (m :: * -> *). MonadIO m => m Context
getContext
    Request
req' <- forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
    Response ByteString
resp <- forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
Simple.httpLBS Request
req'
    ()
_ <- forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response ByteString
resp
    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
t <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
t Text
"httpNoBody" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
    Context
ctxt <- forall (m :: * -> *). MonadIO m => m Context
getContext
    Request
req' <- forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
    Response ()
resp <- forall (m :: * -> *). MonadIO m => Request -> m (Response ())
Simple.httpNoBody Request
req'
    ()
_ <- forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response ()
resp
    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
t <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
t Text
"httpJSON" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
    Context
ctxt <- forall (m :: * -> *). MonadIO m => m Context
getContext
    Request
req' <- forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
    Response a
resp <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
Simple.httpJSON Request
req'
    ()
_ <- forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response a
resp
    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
t <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
t Text
"httpJSONEither" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
    Context
ctxt <- forall (m :: * -> *). MonadIO m => m Context
getContext
    Request
req' <- forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
    Response (Either JSONException a)
resp <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response (Either JSONException a))
Simple.httpJSONEither Request
req'
    ()
_ <- forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response (Either JSONException a)
resp
    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
t <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
t Text
"httpSink" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
    Context
ctxt <- forall (m :: * -> *). MonadIO m => m Context
getContext
    Request
req' <- forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
    forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response () -> ConduitM ByteString Void m a) -> m a
Simple.httpSink Request
req' forall a b. (a -> b) -> a -> b
$ \Response ()
resp -> do
      ()
_ <- 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
t <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  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
t Text
"httpSource" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
    Context
ctxt <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). MonadIO m => m Context
getContext
    Request
req' <- forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
    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' forall a b. (a -> b) -> a -> b
$ \Response (ConduitM i ByteString m ())
resp -> do
      ()
_ <- 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
t <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
t Text
"withResponse" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
    Context
ctxt <- forall (m :: * -> *). MonadIO m => m Context
getContext
    Request
req' <- forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
    forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
Simple.withResponse Request
req' forall a b. (a -> b) -> a -> b
$ \Response (ConduitM i ByteString m ())
resp -> do
      ()
_ <- 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