{-# LANGUAGE OverloadedStrings #-}
module OpenTelemetry.Instrumentation.Cloudflare where

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)
import Control.Monad (forM_)
import Data.Maybe
import qualified Data.List
import qualified Data.CaseInsensitive as CI

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
  Maybe Context -> (Context -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Context
mCtxt ((Context -> IO ()) -> IO ()) -> (Context -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Context
ctxt -> do
    Maybe Span -> (Span -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Context -> Maybe Span
lookupSpan Context
ctxt) ((Span -> IO ()) -> IO ()) -> (Span -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Span
span_ -> do
      Span -> [(Text, Attribute)] -> IO ()
forall (m :: * -> *).
MonadIO m =>
Span -> [(Text, Attribute)] -> m ()
addAttributes Span
span_ ([(Text, Attribute)] -> IO ()) -> [(Text, Attribute)] -> IO ()
forall a b. (a -> b) -> a -> b
$ (HeaderName -> [(Text, Attribute)])
-> [HeaderName] -> [(Text, Attribute)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (\HeaderName
hn -> case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Data.List.lookup HeaderName
hn ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req of
            Maybe ByteString
Nothing -> []
            Just ByteString
val -> 
              [ (Text
"http.request.header." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase HeaderName
hn)
                , 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
val
                )
              ]
        )
        [HeaderName]
headers
  Application
app Request
req Response -> IO ResponseReceived
sendResp
  where
    headers :: [HeaderName]
headers =
      [ HeaderName
"cf-connecting-ip"
      , HeaderName
"true-client-ip"
      , HeaderName
"cf-ray"
      -- CF-Visitor
      , HeaderName
"cf-ipcountry"
      -- CDN-Loop
      , HeaderName
"cf-worker"
      ]