{-# 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 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 :: SpanKind
kind = SpanKind
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
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
_wrSpan -> do
    Context
ctxt <- 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' <- forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
httpConf Context
ctxt Request
req
    m a -> IO a
runInIO <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
Client.withResponse Request
req' Manager
man forall a b. (a -> b) -> a -> b
$ \Response BodyReader
resp -> do
      ()
_ <- forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response BodyReader
resp
      m a -> IO a
runInIO 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
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
_ -> 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 :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
Client.httpLbs Request
req' Manager
man
    ()
_ <- 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


{- | 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
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
_ -> 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 :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ())
Client.httpNoBody Request
req' Manager
man
    ()
_ <- 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


{- | 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
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
"responseOpen" (HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
spanArgs) forall a b. (a -> b) -> a -> b
$ \Span
_ -> 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 BodyReader
resp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response BodyReader)
Client.responseOpen Request
req' Manager
man
    ()
_ <- forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
httpConf Context
ctxt Response BodyReader
resp
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Response BodyReader
resp