{-# LANGUAGE OverloadedStrings #-}
module OpenTelemetry.Instrumentation.HttpClient.Raw where
import Control.Applicative ((<|>))
import Control.Monad.IO.Class
import OpenTelemetry.Context (Context, lookupSpan)
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Trace.Core
import OpenTelemetry.Propagator
import Network.HTTP.Client
import Network.HTTP.Types
import Control.Monad (forM_, when)
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Foldable (Foldable(toList))
import Data.CaseInsensitive (foldedCase)
import qualified Data.Maybe

data HttpClientInstrumentationConfig = HttpClientInstrumentationConfig
  { HttpClientInstrumentationConfig -> Maybe Text
requestName :: Maybe T.Text
  , HttpClientInstrumentationConfig -> [HeaderName]
requestHeadersToRecord :: [HeaderName]
  , HttpClientInstrumentationConfig -> [HeaderName]
responseHeadersToRecord :: [HeaderName]
  }

instance Semigroup HttpClientInstrumentationConfig where
  HttpClientInstrumentationConfig
l <> :: HttpClientInstrumentationConfig
-> HttpClientInstrumentationConfig
-> HttpClientInstrumentationConfig
<> HttpClientInstrumentationConfig
r = HttpClientInstrumentationConfig :: Maybe Text
-> [HeaderName] -> [HeaderName] -> HttpClientInstrumentationConfig
HttpClientInstrumentationConfig
    { requestName :: Maybe Text
requestName = HttpClientInstrumentationConfig -> Maybe Text
requestName HttpClientInstrumentationConfig
r Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HttpClientInstrumentationConfig -> Maybe Text
requestName HttpClientInstrumentationConfig
l -- flipped on purpose: last writer wins
    , requestHeadersToRecord :: [HeaderName]
requestHeadersToRecord = HttpClientInstrumentationConfig -> [HeaderName]
requestHeadersToRecord HttpClientInstrumentationConfig
l [HeaderName] -> [HeaderName] -> [HeaderName]
forall a. Semigroup a => a -> a -> a
<> HttpClientInstrumentationConfig -> [HeaderName]
requestHeadersToRecord HttpClientInstrumentationConfig
r
    , responseHeadersToRecord :: [HeaderName]
responseHeadersToRecord = HttpClientInstrumentationConfig -> [HeaderName]
responseHeadersToRecord HttpClientInstrumentationConfig
l [HeaderName] -> [HeaderName] -> [HeaderName]
forall a. Semigroup a => a -> a -> a
<> HttpClientInstrumentationConfig -> [HeaderName]
responseHeadersToRecord HttpClientInstrumentationConfig
r
    }

instance Monoid HttpClientInstrumentationConfig where
  mempty :: HttpClientInstrumentationConfig
mempty = HttpClientInstrumentationConfig :: Maybe Text
-> [HeaderName] -> [HeaderName] -> HttpClientInstrumentationConfig
HttpClientInstrumentationConfig
    { requestName :: Maybe Text
requestName = Maybe Text
forall a. Maybe a
Nothing
    , requestHeadersToRecord :: [HeaderName]
requestHeadersToRecord = [HeaderName]
forall a. Monoid a => a
mempty
    , responseHeadersToRecord :: [HeaderName]
responseHeadersToRecord = [HeaderName]
forall a. Monoid a => a
mempty
    }

httpClientInstrumentationConfig :: HttpClientInstrumentationConfig
httpClientInstrumentationConfig :: HttpClientInstrumentationConfig
httpClientInstrumentationConfig = HttpClientInstrumentationConfig
forall a. Monoid a => a
mempty

  -- TODO see if we can avoid recreating this on each request without being more invasive with the interface
httpTracerProvider :: MonadIO m => m Tracer
httpTracerProvider :: m Tracer
httpTracerProvider = do
  TracerProvider
tp <- m TracerProvider
forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider
  Tracer -> m Tracer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tracer -> m Tracer) -> Tracer -> m Tracer
forall a b. (a -> b) -> a -> b
$ TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer
makeTracer TracerProvider
tp InstrumentationLibrary
"hs-opentelemetry-instrumentation-http-client" TracerOptions
tracerOptions

instrumentRequest
  :: MonadIO m
  => HttpClientInstrumentationConfig
  -> Context
  -> Request
  -> m Request
instrumentRequest :: HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
conf Context
ctxt Request
req = do
  Tracer
tp <- m Tracer
forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  Maybe Span -> (Span -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Context -> Maybe Span
lookupSpan Context
ctxt) ((Span -> m ()) -> m ()) -> (Span -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Span
s -> do
    let url :: Text
url =
          ByteString -> Text
T.decodeUtf8
          ((if Request -> Bool
secure Request
req then ByteString
"https://" else ByteString
"http://") ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
host Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Request -> Int
port Request
req) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
path Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
queryString Request
req)
    Span -> Text -> m ()
forall (m :: * -> *). MonadIO m => Span -> Text -> m ()
updateName Span
s (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Text
url (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ HttpClientInstrumentationConfig -> Maybe Text
requestName HttpClientInstrumentationConfig
conf
    Span -> [(Text, Attribute)] -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> [(Text, Attribute)] -> m ()
addAttributes Span
s
      [ ( Text
"http.method", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
method Request
req)
      , ( Text
"http.url", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute Text
url)
      , ( Text
"http.target", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (Request -> ByteString
path Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
queryString Request
req))
      , ( Text
"http.host", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
host Request
req)
      , ( Text
"http.scheme", PrimitiveAttribute -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (PrimitiveAttribute -> Attribute)
-> PrimitiveAttribute -> Attribute
forall a b. (a -> b) -> a -> b
$ Text -> PrimitiveAttribute
TextAttribute (Text -> PrimitiveAttribute) -> Text -> PrimitiveAttribute
forall a b. (a -> b) -> a -> b
$ if Request -> Bool
secure Request
req then Text
"https" else Text
"http")
      , ( Text
"http.flavor"
        , Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ case Request -> HttpVersion
requestVersion Request
req of
            (HttpVersion Int
major Int
minor) -> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
major String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
minor)
        )
      , ( Text
"http.user_agent"
        , Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Text -> (ByteString -> Text) -> Maybe ByteString -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ByteString -> Text
T.decodeUtf8 (HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hUserAgent ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)
        )
      ]
    Span -> [(Text, Attribute)] -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> [(Text, Attribute)] -> m ()
addAttributes Span
s ([(Text, Attribute)] -> m ()) -> [(Text, Attribute)] -> m ()
forall a b. (a -> b) -> a -> b
$
      (HeaderName -> [(Text, Attribute)])
-> [HeaderName] -> [(Text, Attribute)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (\HeaderName
h -> Maybe (Text, Attribute) -> [(Text, Attribute)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (Text, Attribute) -> [(Text, Attribute)])
-> Maybe (Text, Attribute) -> [(Text, Attribute)]
forall a b. (a -> b) -> a -> b
$ (\ByteString
v -> (Text
"http.request.header." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (HeaderName -> ByteString
forall s. CI s -> s
foldedCase HeaderName
h), Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (ByteString -> Text
T.decodeUtf8 ByteString
v))) (ByteString -> (Text, Attribute))
-> Maybe ByteString -> Maybe (Text, Attribute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
h (Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)) ([HeaderName] -> [(Text, Attribute)])
-> [HeaderName] -> [(Text, Attribute)]
forall a b. (a -> b) -> a -> b
$
        HttpClientInstrumentationConfig -> [HeaderName]
requestHeadersToRecord HttpClientInstrumentationConfig
conf

  [(HeaderName, ByteString)]
hdrs <- Propagator
  Context [(HeaderName, ByteString)] [(HeaderName, ByteString)]
-> Context
-> [(HeaderName, ByteString)]
-> m [(HeaderName, ByteString)]
forall (m :: * -> *) context i o.
MonadIO m =>
Propagator context i o -> context -> o -> m o
inject (TracerProvider
-> Propagator
     Context [(HeaderName, ByteString)] [(HeaderName, ByteString)]
getTracerProviderPropagators (TracerProvider
 -> Propagator
      Context [(HeaderName, ByteString)] [(HeaderName, ByteString)])
-> TracerProvider
-> Propagator
     Context [(HeaderName, ByteString)] [(HeaderName, ByteString)]
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
getTracerTracerProvider Tracer
tp) Context
ctxt ([(HeaderName, ByteString)] -> m [(HeaderName, ByteString)])
-> [(HeaderName, ByteString)] -> m [(HeaderName, ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
  Request -> m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> m Request) -> Request -> m Request
forall a b. (a -> b) -> a -> b
$ Request
req
    { requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = [(HeaderName, ByteString)]
hdrs
    }


instrumentResponse
  :: MonadIO m
  => HttpClientInstrumentationConfig
  -> Context
  -> Response a
  -> m ()
instrumentResponse :: HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
conf Context
ctxt Response a
resp = do
  Tracer
tp <- m Tracer
forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
  Context
ctxt' <- Propagator
  Context [(HeaderName, ByteString)] [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> Context -> m Context
forall (m :: * -> *) context i o.
MonadIO m =>
Propagator context i o -> i -> context -> m context
extract (TracerProvider
-> Propagator
     Context [(HeaderName, ByteString)] [(HeaderName, ByteString)]
getTracerProviderPropagators (TracerProvider
 -> Propagator
      Context [(HeaderName, ByteString)] [(HeaderName, ByteString)])
-> TracerProvider
-> Propagator
     Context [(HeaderName, ByteString)] [(HeaderName, ByteString)]
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
getTracerTracerProvider Tracer
tp) (Response a -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response a
resp) Context
ctxt
  Maybe Context
_ <- Context -> m (Maybe Context)
forall (m :: * -> *). MonadIO m => Context -> m (Maybe Context)
attachContext Context
ctxt'
  Maybe Span -> (Span -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Context -> Maybe Span
lookupSpan Context
ctxt') ((Span -> m ()) -> m ()) -> (Span -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Span
s -> do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Int
statusCode (Response a -> Status
forall body. Response body -> Status
responseStatus Response a
resp) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
400) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Span -> SpanStatus -> m ()
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
s (Text -> SpanStatus
Error Text
"")
    Span -> [(Text, Attribute)] -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> [(Text, Attribute)] -> m ()
addAttributes Span
s
      [ (Text
"http.status_code", Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Int -> Attribute) -> Int -> Attribute
forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response a -> Status
forall body. Response body -> Status
responseStatus Response a
resp)
      -- TODO
      -- , ("http.request_content_length",	_)
      -- , ("http.request_content_length_uncompressed",	_)
      -- , ("http.response_content_length", _)
      -- , ("http.response_content_length_uncompressed", _)
      -- , ("net.transport")
      -- , ("net.peer.name")
      -- , ("net.peer.ip")
      -- , ("net.peer.port")
      ]
    Span -> [(Text, Attribute)] -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> [(Text, Attribute)] -> m ()
addAttributes Span
s ([(Text, Attribute)] -> m ()) -> [(Text, Attribute)] -> m ()
forall a b. (a -> b) -> a -> b
$
      (HeaderName -> [(Text, Attribute)])
-> [HeaderName] -> [(Text, Attribute)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (\HeaderName
h -> Maybe (Text, Attribute) -> [(Text, Attribute)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (Text, Attribute) -> [(Text, Attribute)])
-> Maybe (Text, Attribute) -> [(Text, Attribute)]
forall a b. (a -> b) -> a -> b
$ (\ByteString
v -> (Text
"http.response.header." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (HeaderName -> ByteString
forall s. CI s -> s
foldedCase HeaderName
h), Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (ByteString -> Text
T.decodeUtf8 ByteString
v))) (ByteString -> (Text, Attribute))
-> Maybe ByteString -> Maybe (Text, Attribute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
h (Response a -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response a
resp)) ([HeaderName] -> [(Text, Attribute)])
-> [HeaderName] -> [(Text, Attribute)]
forall a b. (a -> b) -> a -> b
$
        HttpClientInstrumentationConfig -> [HeaderName]
responseHeadersToRecord HttpClientInstrumentationConfig
conf