{-# 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 (mapMaybe)
import qualified 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.Trace.Core
data HttpClientInstrumentationConfig = HttpClientInstrumentationConfig
{ HttpClientInstrumentationConfig -> Maybe Text
requestName :: Maybe T.Text
, :: [HeaderName]
, :: [HeaderName]
}
instance Semigroup HttpClientInstrumentationConfig where
HttpClientInstrumentationConfig
l <> :: HttpClientInstrumentationConfig
-> HttpClientInstrumentationConfig
-> HttpClientInstrumentationConfig
<> HttpClientInstrumentationConfig
r =
HttpClientInstrumentationConfig
{ requestName :: Maybe Text
requestName = HttpClientInstrumentationConfig -> Maybe Text
requestName HttpClientInstrumentationConfig
r forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HttpClientInstrumentationConfig -> Maybe Text
requestName HttpClientInstrumentationConfig
l
, requestHeadersToRecord :: [HeaderName]
requestHeadersToRecord = HttpClientInstrumentationConfig -> [HeaderName]
requestHeadersToRecord HttpClientInstrumentationConfig
l forall a. Semigroup a => a -> a -> a
<> HttpClientInstrumentationConfig -> [HeaderName]
requestHeadersToRecord HttpClientInstrumentationConfig
r
, responseHeadersToRecord :: [HeaderName]
responseHeadersToRecord = HttpClientInstrumentationConfig -> [HeaderName]
responseHeadersToRecord HttpClientInstrumentationConfig
l forall a. Semigroup a => a -> a -> a
<> HttpClientInstrumentationConfig -> [HeaderName]
responseHeadersToRecord HttpClientInstrumentationConfig
r
}
instance Monoid HttpClientInstrumentationConfig where
mempty :: HttpClientInstrumentationConfig
mempty =
HttpClientInstrumentationConfig
{ requestName :: Maybe Text
requestName = forall a. Maybe a
Nothing
, requestHeadersToRecord :: [HeaderName]
requestHeadersToRecord = forall a. Monoid a => a
mempty
, responseHeadersToRecord :: [HeaderName]
responseHeadersToRecord = forall a. Monoid a => a
mempty
}
httpClientInstrumentationConfig :: HttpClientInstrumentationConfig
httpClientInstrumentationConfig :: HttpClientInstrumentationConfig
httpClientInstrumentationConfig = forall a. Monoid a => a
mempty
httpTracerProvider :: (MonadIO m) => m Tracer
httpTracerProvider :: forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider = do
TracerProvider
tp <- forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
tp <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Context -> Maybe Span
lookupSpan Context
ctxt) 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://") forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
host Request
req forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Request -> Int
port Request
req) forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
path Request
req forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
queryString Request
req)
forall (m :: * -> *). MonadIO m => Span -> Text -> m ()
updateName Span
s forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Text
url forall a b. (a -> b) -> a -> b
$ HttpClientInstrumentationConfig -> Maybe Text
requestName HttpClientInstrumentationConfig
conf
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes
Span
s
[ (Text
"http.method", forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ Request -> ByteString
method Request
req)
, (Text
"http.url", forall a. ToAttribute a => a -> Attribute
toAttribute Text
url)
, (Text
"http.target", forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (Request -> ByteString
path Request
req forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
queryString Request
req))
, (Text
"http.host", forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ Request -> ByteString
host Request
req)
, (Text
"http.scheme", forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ Text -> PrimitiveAttribute
TextAttribute forall a b. (a -> b) -> a -> b
$ if Request -> Bool
secure Request
req then Text
"https" else Text
"http")
,
( Text
"http.flavor"
, forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ case Request -> HttpVersion
requestVersion Request
req of
(HttpVersion Int
major Int
minor) -> String -> Text
T.pack (forall a. Show a => a -> String
show Int
major forall a. Semigroup a => a -> a -> a
<> String
"." forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
minor)
)
,
( Text
"http.user_agent"
, forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ByteString -> Text
T.decodeUtf8 (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hUserAgent forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req)
)
]
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
s
forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(\HeaderName
h -> (\ByteString
v -> (Text
"http.request.header." forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (forall s. CI s -> s
foldedCase HeaderName
h), forall a. ToAttribute a => a -> Attribute
toAttribute (ByteString -> Text
T.decodeUtf8 ByteString
v))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
h (Request -> RequestHeaders
requestHeaders Request
req))
forall a b. (a -> b) -> a -> b
$ HttpClientInstrumentationConfig -> [HeaderName]
requestHeadersToRecord HttpClientInstrumentationConfig
conf
RequestHeaders
hdrs <- forall (m :: * -> *) context i o.
MonadIO m =>
Propagator context i o -> context -> o -> m o
inject (TracerProvider -> Propagator Context RequestHeaders RequestHeaders
getTracerProviderPropagators forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
getTracerTracerProvider Tracer
tp) Context
ctxt forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Request
req
{ requestHeaders :: RequestHeaders
requestHeaders = 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
tp <- forall (m :: * -> *). MonadIO m => m Tracer
httpTracerProvider
Context
ctxt' <- forall (m :: * -> *) context i o.
MonadIO m =>
Propagator context i o -> i -> context -> m context
extract (TracerProvider -> Propagator Context RequestHeaders RequestHeaders
getTracerProviderPropagators forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
getTracerTracerProvider Tracer
tp) (forall body. Response body -> RequestHeaders
responseHeaders Response a
resp) Context
ctxt
Maybe Context
_ <- forall (m :: * -> *). MonadIO m => Context -> m (Maybe Context)
attachContext Context
ctxt'
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Context -> Maybe Span
lookupSpan Context
ctxt') forall a b. (a -> b) -> a -> b
$ \Span
s -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Int
statusCode (forall body. Response body -> Status
responseStatus Response a
resp) forall a. Ord a => a -> a -> Bool
>= Int
400) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
s (Text -> SpanStatus
Error Text
"")
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes
Span
s
[ (Text
"http.status_code", forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode forall a b. (a -> b) -> a -> b
$ forall body. Response body -> Status
responseStatus Response a
resp)
]
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
s
forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(\HeaderName
h -> (\ByteString
v -> (Text
"http.response.header." forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (forall s. CI s -> s
foldedCase HeaderName
h), forall a. ToAttribute a => a -> Attribute
toAttribute (ByteString -> Text
T.decodeUtf8 ByteString
v))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
h (forall body. Response body -> RequestHeaders
responseHeaders Response a
resp))
forall a b. (a -> b) -> a -> b
$ HttpClientInstrumentationConfig -> [HeaderName]
responseHeadersToRecord HttpClientInstrumentationConfig
conf