{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}

module OpenTelemetry.Instrumentation.HttpClient.Raw where

import Control.Applicative ((<|>))
import Control.Monad (forM_, when)
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as B
import Data.CaseInsensitive (foldedCase)
import qualified Data.HashMap.Strict as H
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Client
import Network.HTTP.Types
import OpenTelemetry.Context (Context, lookupSpan)
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Propagator
import OpenTelemetry.SemanticsConfig
import OpenTelemetry.Trace.Core


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
      { requestName :: Maybe Text
requestName = HttpClientInstrumentationConfig -> Maybe Text
requestName HttpClientInstrumentationConfig
r Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
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
      { 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 :: forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider = do
  TracerProvider
tp <- m TracerProvider
forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider
  Tracer -> m Tracer
forall a. a -> m a
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 :: forall (m :: * -> *).
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Request -> m Request
instrumentRequest HttpClientInstrumentationConfig
conf Context
ctxt Request
req = do
  Tracer
tracer <- 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
fromMaybe Text
url (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ HttpClientInstrumentationConfig -> Maybe Text
requestName HttpClientInstrumentationConfig
conf

    let addStableAttributes :: m ()
addStableAttributes = do
          Span -> HashMap Text Attribute -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes
            Span
s
            [ (Text
"http.request.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
"url.full", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute Text
url)
            , (Text
"url.path", 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
path Request
req)
            , (Text
"url.query", 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
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
"url.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
"network.protocol.version"
              , 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
"user_agent.original"
              , 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 -> HashMap Text Attribute -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
s
            (HashMap Text Attribute -> m ()) -> HashMap Text Attribute -> m ()
forall a b. (a -> b) -> a -> b
$ [(Text, Attribute)] -> HashMap Text Attribute
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
            ([(Text, Attribute)] -> HashMap Text Attribute)
-> [(Text, Attribute)] -> HashMap Text Attribute
forall a b. (a -> b) -> a -> b
$ (HeaderName -> Maybe (Text, Attribute))
-> [HeaderName] -> [(Text, Attribute)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              (\HeaderName
h -> (\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

        addOldAttributes :: m ()
addOldAttributes = do
          Span -> HashMap Text Attribute -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap 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 -> HashMap Text Attribute -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
s
            (HashMap Text Attribute -> m ()) -> HashMap Text Attribute -> m ()
forall a b. (a -> b) -> a -> b
$ [(Text, Attribute)] -> HashMap Text Attribute
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
            ([(Text, Attribute)] -> HashMap Text Attribute)
-> [(Text, Attribute)] -> HashMap Text Attribute
forall a b. (a -> b) -> a -> b
$ (HeaderName -> Maybe (Text, Attribute))
-> [HeaderName] -> [(Text, Attribute)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              (\HeaderName
h -> (\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

    SemanticsOptions
semanticsOptions <- IO SemanticsOptions -> m SemanticsOptions
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SemanticsOptions
getSemanticsOptions
    case SemanticsOptions -> HttpOption
httpOption SemanticsOptions
semanticsOptions of
      HttpOption
Stable -> m ()
addStableAttributes
      HttpOption
StableAndOld -> m ()
addStableAttributes m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
addOldAttributes
      HttpOption
Old -> m ()
addOldAttributes

  [(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
tracer) 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 a. a -> m a
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 = hdrs
      }


instrumentResponse
  :: (MonadIO m)
  => HttpClientInstrumentationConfig
  -> Context
  -> Response a
  -> m ()
instrumentResponse :: forall (m :: * -> *) a.
MonadIO m =>
HttpClientInstrumentationConfig -> Context -> Response a -> m ()
instrumentResponse HttpClientInstrumentationConfig
conf Context
ctxt Response a
resp = do
  Tracer
tracer <- 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
tracer) (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
"")
    let addStableAttributes :: m ()
addStableAttributes = do
          Span -> HashMap Text Attribute -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes
            Span
s
            [ (Text
"http.response.statusCode", 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.body.size",	_)
            -- , ("http.request_content_length_uncompressed",	_)
            -- , ("http.response.body.size", _)
            -- , ("http.response_content_length_uncompressed", _)
            -- , ("net.transport")
            -- , ("server.address")
            -- , ("server.port")
            ]
          Span -> HashMap Text Attribute -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
s
            (HashMap Text Attribute -> m ()) -> HashMap Text Attribute -> m ()
forall a b. (a -> b) -> a -> b
$ [(Text, Attribute)] -> HashMap Text Attribute
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
            ([(Text, Attribute)] -> HashMap Text Attribute)
-> [(Text, Attribute)] -> HashMap Text Attribute
forall a b. (a -> b) -> a -> b
$ (HeaderName -> Maybe (Text, Attribute))
-> [HeaderName] -> [(Text, Attribute)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              (\HeaderName
h -> (\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
        addOldAttributes :: m ()
addOldAttributes = do
          Span -> HashMap Text Attribute -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap 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 -> HashMap Text Attribute -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
s
            (HashMap Text Attribute -> m ()) -> HashMap Text Attribute -> m ()
forall a b. (a -> b) -> a -> b
$ [(Text, Attribute)] -> HashMap Text Attribute
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
            ([(Text, Attribute)] -> HashMap Text Attribute)
-> [(Text, Attribute)] -> HashMap Text Attribute
forall a b. (a -> b) -> a -> b
$ (HeaderName -> Maybe (Text, Attribute))
-> [HeaderName] -> [(Text, Attribute)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              (\HeaderName
h -> (\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

    SemanticsOptions
semanticsOptions <- IO SemanticsOptions -> m SemanticsOptions
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SemanticsOptions
getSemanticsOptions
    case SemanticsOptions -> HttpOption
httpOption SemanticsOptions
semanticsOptions of
      HttpOption
Stable -> m ()
addStableAttributes
      HttpOption
StableAndOld -> m ()
addStableAttributes m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
addOldAttributes
      HttpOption
Old -> m ()
addOldAttributes