hs-opentelemetry-instrumentation-cloudflare 0.1.0.0 → 0.2.0.0

raw patch · 5 files changed

+51/−33 lines, 5 filesdep +unordered-containersdep ~hs-opentelemetry-apisetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: unordered-containers

Dependency ranges changed: hs-opentelemetry-api

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• Setup.hs +2/−0
• hs-opentelemetry-instrumentation-cloudflare.cabal +16/−14
• src/OpenTelemetry/Instrumentation/Cloudflare.hs +26/−19
• test/Spec.hs +1/−0

@@ -1,3 +1,9 @@ # Changelog for cloudflare  ## Unreleased changes++## 0.2.0.0++### Breaking changes++- Use `HashMap Text Attribute` instead of `[(Text, Attribute)]` as attributes

@@ -1,2 +1,4 @@ import Distribution.Simple++ main = defaultMain

@@ -1,20 +1,20 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack -name:           hs-opentelemetry-instrumentation-cloudflare-version:        0.1.0.0-description:    Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/cloudflare#readme>-homepage:       https://github.com/iand675/hs-opentelemetry#readme-bug-reports:    https://github.com/iand675/hs-opentelemetry/issues-author:         Ian Duncan-maintainer:     ian@iankduncan.com-copyright:      2021 Ian Duncan-license:        BSD3-license-file:   LICENSE-build-type:     Simple+name:               hs-opentelemetry-instrumentation-cloudflare+version:            0.2.0.0+description:        Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/cloudflare#readme>+homepage:           https://github.com/iand675/hs-opentelemetry#readme+bug-reports:        https://github.com/iand675/hs-opentelemetry/issues+author:             Ian Duncan, Jade Lovelace+maintainer:         ian@iankduncan.com+copyright:          2023 Ian Duncan, Mercury Technologies+license:            BSD3+license-file:       LICENSE+build-type:         Simple extra-source-files:     README.md     ChangeLog.md@@ -33,10 +33,11 @@   build-depends:       base >=4.7 && <5     , case-insensitive-    , hs-opentelemetry-api ==0.0.3.*+    , hs-opentelemetry-api ==0.1.*     , hs-opentelemetry-instrumentation-wai     , http-types     , text+    , unordered-containers     , wai   default-language: Haskell2010 @@ -51,10 +52,11 @@   build-depends:       base >=4.7 && <5     , case-insensitive-    , hs-opentelemetry-api ==0.0.3.*+    , hs-opentelemetry-api ==0.1.*     , hs-opentelemetry-instrumentation-conduit     , hs-opentelemetry-instrumentation-wai     , http-types     , text+    , unordered-containers     , wai   default-language: Haskell2010

@@ -1,41 +1,48 @@+{-# 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.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 app req sendResp = do   let mCtxt = requestContext req   forM_ mCtxt $ \ctxt -> do     forM_ (lookupSpan ctxt) $ \span_ -> do-      addAttributes span_ $ concatMap-        (\hn -> case Data.List.lookup hn $ requestHeaders req of-            Nothing -> []-            Just val -> -              [ ("http.request.header." <> T.decodeUtf8 (CI.foldedCase hn)-                , toAttribute $ T.decodeUtf8 val-                )-              ]-        )-        headers+      addAttributes span_ $+        H.unions $+          fmap+            ( \hn -> case Data.List.lookup hn $ requestHeaders req of+                Nothing -> []+                Just val ->+                  [+                    ( "http.request.header." <> T.decodeUtf8 (CI.foldedCase hn)+                    , toAttribute $ T.decodeUtf8 val+                    )+                  ]+            )+            headers   app req sendResp   where     headers =       [ "cf-connecting-ip"       , "true-client-ip"       , "cf-ray"-      -- CF-Visitor-      , "cf-ipcountry"-      -- CDN-Loop-      , "cf-worker"+      , -- CF-Visitor+        "cf-ipcountry"+      , -- CDN-Loop+        "cf-worker"       ]

@@ -1,2 +1,3 @@+ main :: IO () main = putStrLn "Test suite not yet implemented"