{-# 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
  , 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 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 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


-- 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 <- 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)
      -- 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")
      ]
    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