{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

{- |
[New HTTP semantic conventions have been declared stable.](https://opentelemetry.io/blog/2023/http-conventions-declared-stable/#migration-plan) Opt-in by setting the environment variable OTEL_SEMCONV_STABILITY_OPT_IN to
- "http" - to use the stable conventions
- "http/dup" - to emit both the old and the stable conventions
Otherwise, the old conventions will be used. The stable conventions will replace the old conventions in the next major release of this library.
-}
module OpenTelemetry.Instrumentation.Wai (
  newOpenTelemetryWaiMiddleware,
  newOpenTelemetryWaiMiddleware',
  requestContext,
) where

import Control.Exception (bracket)
import Control.Monad
import qualified Data.HashMap.Strict as H
import Data.IP (fromHostAddress, fromHostAddress6)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vault.Lazy as Vault
import GHC.Stack (HasCallStack)
import Network.HTTP.Types
import Network.Socket
import Network.Wai
import OpenTelemetry.Attributes (lookupAttribute)
import qualified OpenTelemetry.Context as Context
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Propagator
import OpenTelemetry.SemanticsConfig
import OpenTelemetry.Trace.Core
import System.IO.Unsafe


newOpenTelemetryWaiMiddleware :: (HasCallStack) => IO Middleware
newOpenTelemetryWaiMiddleware :: HasCallStack => IO Middleware
newOpenTelemetryWaiMiddleware = HasCallStack => TracerProvider -> Middleware
TracerProvider -> Middleware
newOpenTelemetryWaiMiddleware' (TracerProvider -> Middleware)
-> IO TracerProvider -> IO Middleware
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO TracerProvider
forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider


newOpenTelemetryWaiMiddleware'
  :: (HasCallStack)
  => TracerProvider
  -> Middleware
newOpenTelemetryWaiMiddleware' :: HasCallStack => TracerProvider -> Middleware
newOpenTelemetryWaiMiddleware' TracerProvider
tp =
  let waiTracer :: Tracer
waiTracer =
        TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer
makeTracer
          TracerProvider
tp
          $Addr#
Int
HashMap Text Attribute
Addr# -> Int -> Text
Text -> Text -> Text -> Attributes -> InstrumentationLibrary
HashMap Text Attribute -> Int -> Int -> Attributes
forall k v. HashMap k v
detectInstrumentationLibrary
          (Maybe Text -> TracerOptions
TracerOptions Maybe Text
forall a. Maybe a
Nothing)
  in Tracer -> Middleware
middleware Tracer
waiTracer
  where
    usefulCallsite :: HashMap Text Attribute
usefulCallsite = HashMap Text Attribute
HasCallStack => HashMap Text Attribute
callerAttributes
    middleware :: Tracer -> Middleware
    middleware :: Tracer -> Middleware
middleware Tracer
tracer Application
app Request
req Response -> IO ResponseReceived
sendResp = do
      let propagator :: Propagator Context ResponseHeaders ResponseHeaders
propagator = TracerProvider
-> Propagator Context ResponseHeaders ResponseHeaders
getTracerProviderPropagators (TracerProvider
 -> Propagator Context ResponseHeaders ResponseHeaders)
-> TracerProvider
-> Propagator Context ResponseHeaders ResponseHeaders
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
getTracerTracerProvider Tracer
tracer
      let parentContextM :: IO (Maybe Context)
parentContextM = do
            Context
ctx <- IO Context
forall (m :: * -> *). MonadIO m => m Context
getContext
            Context
ctxt <- Propagator Context ResponseHeaders ResponseHeaders
-> ResponseHeaders -> Context -> IO Context
forall (m :: * -> *) context i o.
MonadIO m =>
Propagator context i o -> i -> context -> m context
extract Propagator Context ResponseHeaders ResponseHeaders
propagator (Request -> ResponseHeaders
requestHeaders Request
req) Context
ctx
            Context -> IO (Maybe Context)
forall (m :: * -> *). MonadIO m => Context -> m (Maybe Context)
attachContext Context
ctxt
      let path_ :: Text
path_ = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawPathInfo Request
req
      -- peer = remoteHost req

      SemanticsOptions
semanticsOptions <- IO SemanticsOptions
getSemanticsOptions
      let args :: SpanArguments
args =
            SpanArguments
defaultSpanArguments
              { kind = Server
              , attributes =
                  case httpOption semanticsOptions of
                    HttpOption
Stable ->
                      HashMap Text Attribute
usefulCallsite
                        HashMap Text Attribute
-> HashMap Text Attribute -> HashMap Text Attribute
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
`H.union` [
                                    ( 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 -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hUserAgent (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req)
                                    )
                                  ]
                    HttpOption
StableAndOld ->
                      HashMap Text Attribute
usefulCallsite
                        HashMap Text Attribute
-> HashMap Text Attribute -> HashMap Text Attribute
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
`H.union` [
                                    ( 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 -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hUserAgent (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req)
                                    )
                                  ]
                    HttpOption
Old -> HashMap Text Attribute
usefulCallsite
              }
      -- The cleanup action in this bracket is used to prevent propagated
      -- context from being inherited by any subsequent requests served by the
      -- same thread. Warp supports HTTP keep-alive/persistent connections,
      -- which means a thread can handle multiple requests before exiting.
      IO (Maybe Context)
-> (Maybe Context -> IO ())
-> (Maybe Context -> IO ResponseReceived)
-> IO ResponseReceived
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Maybe Context)
parentContextM (IO () -> Maybe Context -> IO ()
forall a b. a -> b -> a
const (IO () -> Maybe Context -> IO ())
-> IO () -> Maybe Context -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe Context) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO (Maybe Context)
forall (m :: * -> *). MonadIO m => m (Maybe Context)
detachContext) ((Maybe Context -> IO ResponseReceived) -> IO ResponseReceived)
-> (Maybe Context -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Maybe Context
_ -> Tracer
-> Text
-> SpanArguments
-> (Span -> IO ResponseReceived)
-> IO ResponseReceived
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
tracer Text
path_ SpanArguments
args ((Span -> IO ResponseReceived) -> IO ResponseReceived)
-> (Span -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Span
requestSpan -> do
        Context
ctxt <- IO Context
forall (m :: * -> *). MonadIO m => m Context
getContext

        let addStableAttributes :: IO ()
addStableAttributes = do
              Span -> HashMap Text Attribute -> IO ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes
                Span
requestSpan
                [ (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
requestMethod Request
req)
                , -- , ( "url.full",
                  --     toAttribute $
                  --     T.decodeUtf8
                  --     ((if secure req then "https://" else "http://") <> host req <> ":" <> B.pack (show $ port req) <> path req <> queryString req)
                  --   )
                  (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
rawPathInfo 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
rawQueryString Request
req)
                , -- , ( "http.host", toAttribute $ T.decodeUtf8 $ host req)
                  -- , ( "url.scheme", toAttribute $ TextAttribute $ if secure req then "https" else "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
httpVersion Request
req of
                      (HttpVersion Int
major Int
minor) ->
                        String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                          if Int
minor Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                            then Int -> String
forall a. Show a => a -> String
show Int
major
                            else 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
                  )
                , -- TODO HTTP/3 will require detecting this dynamically
                  (Text
"net.transport", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text
"ip_tcp" :: T.Text))
                ]

              Span -> HashMap Text Attribute -> IO ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
requestSpan (HashMap Text Attribute -> IO ())
-> HashMap Text Attribute -> IO ()
forall a b. (a -> b) -> a -> b
$ case Request -> SockAddr
remoteHost Request
req of
                SockAddrInet PortNumber
port HostAddress
addr ->
                  [ (Text
"server.port", Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port :: Int))
                  , (Text
"server.address", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IPv4 -> String
forall a. Show a => a -> String
show (IPv4 -> String) -> IPv4 -> String
forall a b. (a -> b) -> a -> b
$ HostAddress -> IPv4
fromHostAddress HostAddress
addr)
                  ]
                SockAddrInet6 PortNumber
port HostAddress
_ HostAddress6
addr HostAddress
_ ->
                  [ (Text
"server.port", Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port :: Int))
                  , (Text
"server.address", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IPv6 -> String
forall a. Show a => a -> String
show (IPv6 -> String) -> IPv6 -> String
forall a b. (a -> b) -> a -> b
$ HostAddress6 -> IPv6
fromHostAddress6 HostAddress6
addr)
                  ]
                SockAddrUnix String
path ->
                  [ (Text
"server.address", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
path)
                  ]
            addOldAttributes :: IO ()
addOldAttributes = do
              Span -> HashMap Text Attribute -> IO ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes
                Span
requestSpan
                [ (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
requestMethod Request
req)
                , -- , ( "http.url",
                  --     toAttribute $
                  --     T.decodeUtf8
                  --     ((if secure req then "https://" else "http://") <> host req <> ":" <> B.pack (show $ port req) <> path req <> queryString req)
                  --   )
                  (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
rawPathInfo Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
rawQueryString Request
req))
                , -- , ( "http.host", toAttribute $ T.decodeUtf8 $ host req)
                  -- , ( "http.scheme", toAttribute $ TextAttribute $ if secure req then "https" else "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
httpVersion 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 -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hUserAgent (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req)
                  )
                , -- TODO HTTP/3 will require detecting this dynamically
                  (Text
"net.transport", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text
"ip_tcp" :: T.Text))
                ]

              -- TODO this is warp dependent, probably.
              -- , ( "net.host.ip")
              -- , ( "net.host.port")
              -- , ( "net.host.name")
              Span -> HashMap Text Attribute -> IO ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
requestSpan (HashMap Text Attribute -> IO ())
-> HashMap Text Attribute -> IO ()
forall a b. (a -> b) -> a -> b
$ case Request -> SockAddr
remoteHost Request
req of
                SockAddrInet PortNumber
port HostAddress
addr ->
                  [ (Text
"net.peer.port", Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port :: Int))
                  , (Text
"net.peer.ip", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IPv4 -> String
forall a. Show a => a -> String
show (IPv4 -> String) -> IPv4 -> String
forall a b. (a -> b) -> a -> b
$ HostAddress -> IPv4
fromHostAddress HostAddress
addr)
                  ]
                SockAddrInet6 PortNumber
port HostAddress
_ HostAddress6
addr HostAddress
_ ->
                  [ (Text
"net.peer.port", Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port :: Int))
                  , (Text
"net.peer.ip", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IPv6 -> String
forall a. Show a => a -> String
show (IPv6 -> String) -> IPv6 -> String
forall a b. (a -> b) -> a -> b
$ HostAddress6 -> IPv6
fromHostAddress6 HostAddress6
addr)
                  ]
                SockAddrUnix String
path ->
                  [ (Text
"net.peer.name", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
path)
                  ]

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

        let req' :: Request
req' =
              Request
req
                { vault =
                    Vault.insert
                      contextKey
                      ctxt
                      (vault req)
                }
        Application
app Request
req' ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
          Context
ctxt' <- IO Context
forall (m :: * -> *). MonadIO m => m Context
getContext
          ResponseHeaders
hs <- Propagator Context ResponseHeaders ResponseHeaders
-> Context -> ResponseHeaders -> IO ResponseHeaders
forall (m :: * -> *) context i o.
MonadIO m =>
Propagator context i o -> context -> o -> m o
inject Propagator Context ResponseHeaders ResponseHeaders
propagator (Span -> Context -> Context
Context.insertSpan Span
requestSpan Context
ctxt') []
          let resp' :: Response
resp' = (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapResponseHeaders (ResponseHeaders
hs ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. [a] -> [a] -> [a]
++) Response
resp
          Attributes
attrs <- Span -> IO Attributes
forall (m :: * -> *). MonadIO m => Span -> m Attributes
spanGetAttributes Span
requestSpan
          Maybe Attribute -> (Attribute -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Attributes -> Text -> Maybe Attribute
lookupAttribute Attributes
attrs Text
"http.route") ((Attribute -> IO ()) -> IO ()) -> (Attribute -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
            AttributeValue (TextAttribute Text
route) -> Span -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Span -> Text -> m ()
updateName Span
requestSpan Text
route
            Attribute
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          case SemanticsOptions -> HttpOption
httpOption SemanticsOptions
semanticsOptions of
            HttpOption
Stable ->
              Span -> HashMap Text Attribute -> IO ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes
                Span
requestSpan
                [ (Text
"http.response.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 -> Status
responseStatus Response
resp)
                ]
            HttpOption
StableAndOld ->
              Span -> HashMap Text Attribute -> IO ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes
                Span
requestSpan
                [ (Text
"http.response.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 -> Status
responseStatus Response
resp)
                , (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 -> Status
responseStatus Response
resp)
                ]
            HttpOption
Old ->
              Span -> HashMap Text Attribute -> IO ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes
                Span
requestSpan
                [ (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 -> Status
responseStatus Response
resp)
                ]
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Int
statusCode (Response -> Status
responseStatus Response
resp) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Span -> SpanStatus -> IO ()
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
requestSpan (Text -> SpanStatus
Error Text
"")
          ResponseReceived
respReceived <- Response -> IO ResponseReceived
sendResp Response
resp'
          Timestamp
ts <- IO Timestamp
forall (m :: * -> *). MonadIO m => m Timestamp
getTimestamp
          Span -> Maybe Timestamp -> IO ()
forall (m :: * -> *). MonadIO m => Span -> Maybe Timestamp -> m ()
endSpan Span
requestSpan (Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just Timestamp
ts)
          ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
respReceived


contextKey :: Vault.Key Context.Context
contextKey :: Key Context
contextKey = IO (Key Context) -> Key Context
forall a. IO a -> a
unsafePerformIO IO (Key Context)
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE contextKey #-}


requestContext :: Request -> Maybe Context.Context
requestContext :: Request -> Maybe Context
requestContext =
  Key Context -> Vault -> Maybe Context
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key Context
contextKey
    (Vault -> Maybe Context)
-> (Request -> Vault) -> Request -> Maybe Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Vault
vault