{-# 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 qualified Data.ByteString.Lazy as L
import Control.Monad.IO.Class ( MonadIO(..) )
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Trace.Core
    ( defaultSpanArguments,
      SpanArguments(kind),
      SpanKind(Client),
      inSpan',
    )

import Network.HTTP.Client as X hiding (withResponse, httpLbs, httpNoBody, responseOpen)
import qualified Network.HTTP.Client as Client
import OpenTelemetry.Instrumentation.HttpClient.Raw
    ( HttpClientInstrumentationConfig(..),
      instrumentRequest,
      instrumentResponse, httpClientInstrumentationConfig, httpTracerProvider )
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) => HttpClientInstrumentationConfig
             -> Client.Request
             -> Client.Manager
             -> (Client.Response Client.BodyReader -> m a)
             -> m a
withResponse :: HttpClientInstrumentationConfig
-> Request -> Manager -> (Response BodyReader -> m a) -> m a
withResponse HttpClientInstrumentationConfig
httpConf Request
req Manager
man Response BodyReader -> m a
f = do
  Tracer
t <- 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
t Text
"withResponse" 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 (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) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response L.ByteString)
httpLbs :: HttpClientInstrumentationConfig
-> Request -> Manager -> m (Response ByteString)
httpLbs HttpClientInstrumentationConfig
httpConf Request
req Manager
man = do
  Tracer
t <- 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
t Text
"httpLbs" 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 (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 (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) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response ())
httpNoBody :: HttpClientInstrumentationConfig
-> Request -> Manager -> m (Response ())
httpNoBody HttpClientInstrumentationConfig
httpConf Request
req Manager
man = do
  Tracer
t <- 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
t Text
"httpNoBody" 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 (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 (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) => HttpClientInstrumentationConfig -> Client.Request -> Client.Manager -> m (Client.Response Client.BodyReader)
responseOpen :: HttpClientInstrumentationConfig
-> Request -> Manager -> m (Response BodyReader)
responseOpen HttpClientInstrumentationConfig
httpConf Request
req Manager
man = do
  Tracer
t <- 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
t Text
"responseOpen" 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Response BodyReader
resp