{-# 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)

[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,
  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}


{- | 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, 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
    -- TODO would like to capture the req/resp time specifically
    -- inSpan "http.request" (defaultSpanArguments { startingKind = Client }) $ \httpReqSpan -> do
    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


{- | 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, 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


{- | A convenient wrapper around 'withResponse' which ignores the response
 body. This is useful, for example, when performing a HEAD request.
-}
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


{- | 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, 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