{-# 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"
      , -- CF-Visitor
        Item [HeaderName]
"cf-ipcountry"
      , -- CDN-Loop
        Item [HeaderName]
"cf-worker"
      ]