{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module OpenTelemetry.Instrumentation.Cloudflare where
import Control.Monad (forM_)
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as H
import qualified Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.Wai
import OpenTelemetry.Attributes (PrimitiveAttribute (..), ToAttribute (..))
import OpenTelemetry.Context
import OpenTelemetry.Instrumentation.Wai (requestContext)
import OpenTelemetry.Trace.Core (addAttributes)
cloudflareInstrumentationMiddleware :: Middleware
cloudflareInstrumentationMiddleware :: Middleware
cloudflareInstrumentationMiddleware Application
app Request
req Response -> IO ResponseReceived
sendResp = do
let mCtxt :: Maybe Context
mCtxt = Request -> Maybe Context
requestContext Request
req
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Context
mCtxt forall a b. (a -> b) -> a -> b
$ \Context
ctxt -> do
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
span_ -> do
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
span_ forall a b. (a -> b) -> a -> b
$
forall k v. (Eq k, Hashable k) => [HashMap k v] -> HashMap k v
H.unions forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
( \HeaderName
hn -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
Data.List.lookup HeaderName
hn forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req of
Maybe ByteString
Nothing -> []
Just ByteString
val ->
[
( Text
"http.request.header." forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (forall s. CI s -> s
CI.foldedCase HeaderName
hn)
, forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
val
)
]
)
[HeaderName]
headers
Application
app Request
req Response -> IO ResponseReceived
sendResp
where
headers :: [HeaderName]
headers =
[ Item [HeaderName]
"cf-connecting-ip"
, Item [HeaderName]
"true-client-ip"
, Item [HeaderName]
"cf-ray"
,
Item [HeaderName]
"cf-ipcountry"
,
Item [HeaderName]
"cf-worker"
]