opentelemetry 0.0.0.0 → 0.0.0.1

raw patch · 5 files changed

+99/−9 lines, 5 filesdep +attoparsecdep +bytestringdep +tasty-hunitPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: attoparsec, bytestring, tasty-hunit

API changes (from Hackage documentation)

Files

• opentelemetry.cabal +11/−1
• src/OpenTelemetry/Common.hs +4/−6
• src/OpenTelemetry/Implicit.hs +9/−2
• src/OpenTelemetry/Propagation.hs +47/−0
• unit-tests/TestPropagation.hs +28/−0

@@ -2,7 +2,7 @@ name:                opentelemetry description:         The OpenTelemetry Haskell Client https://opentelemetry.io category:            OpenTelemetry-version:             0.0.0.0+version:             0.0.0.1 license-file:        LICENSE license:             Apache-2.0 author:              Dmitry Ivanov@@ -19,7 +19,11 @@     BangPatterns     BlockArguments     DataKinds+    DeriveGeneric+    DerivingStrategies+    DerivingVia     FlexibleInstances+    InstanceSigs     LambdaCase     MultiParamTypeClasses     MultiWayIf@@ -46,6 +50,8 @@   import: options   build-depends:     base >= 4.12 && < 5,+    attoparsec,+    bytestring,     clock >= 0.8,     exceptions,     hashable,@@ -58,6 +64,7 @@     OpenTelemetry.Explicit     OpenTelemetry.Implicit     OpenTelemetry.FileExporter+    OpenTelemetry.Propagation  test-suite just-some-usage-code-that-must-compile   import: options@@ -78,10 +85,13 @@   main-is:    Main.hs   other-modules:     TestCommon+    TestPropagation   hs-source-dirs: unit-tests   build-depends:     base,+    bytestring,     tasty,     tasty-quickcheck,+    tasty-hunit,     tasty-discover,     opentelemetry

@@ -1,12 +1,10 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-}  module OpenTelemetry.Common where  import qualified Data.HashMap.Strict as HM import Data.Hashable+import GHC.Generics import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty ((:|)), (<|)) import qualified Data.Text as T@@ -14,11 +12,11 @@ import System.Clock  newtype TraceId = TId Word64-  deriving (Show, Eq)+  deriving (Show, Eq, Generic)   deriving (Hashable) via Word64  newtype SpanId = SId Word64-  deriving (Show, Eq)+  deriving (Show, Eq, Generic)   deriving (Hashable) via Word64  type Timestamp = Word64@@ -62,7 +60,7 @@ createTracer = pure $ Tracer mempty mempty  data SpanContext = SpanContext !SpanId !TraceId-  deriving (Show, Eq)+  deriving (Show, Eq, Generic)  data TagValue   = StringTagValue !T.Text

@@ -11,9 +11,8 @@ import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Maybe import qualified Data.Text as T-import GHC.Conc import OpenTelemetry.Common-import System.IO+import OpenTelemetry.FileExporter import System.IO.Unsafe import System.Random @@ -74,6 +73,14 @@       { gSpanExporter :: !(Exporter Span),         gTracer :: !(Tracer ThreadId)       }++withZeroConfigOpenTelemetry :: (MonadIO m, MonadMask m) => m a -> m a+withZeroConfigOpenTelemetry action = do+  -- TODO(divanov): crossplatformer temporary directory+  -- TODO(divanov): include program name and current date in the filename+  exporter <- liftIO $ createFileSpanExporter "/tmp/opentelemetry.trace.json"+  let otelConfig = OpenTelemetryConfig {otcSpanExporter = exporter}+  withOpenTelemetry otelConfig action  getCurrentActiveSpan :: MonadIO m => m Span getCurrentActiveSpan = do

@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++-- This is an approximate implementation of https://www.w3.org/TR/trace-context++module OpenTelemetry.Propagation where++import Data.Word+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString.Char8 as BS+import Data.Char (ord)+import Data.List (find)+import Data.String+import Debug.Trace+import GHC.Generics+import OpenTelemetry.Common+import Text.Printf++data TraceParent = TraceParent Int Int+  deriving (Eq, Show, Generic)++extractSpanContextFromHeaders :: (IsString key, Eq key) => [(key, BS.ByteString)] -> Maybe SpanContext+extractSpanContextFromHeaders headers =+  case find ((== "traceparent") . fst) headers of+    Just (_, value) -> case parseSpanContext value of+      Just c -> Just c+    _ -> Nothing++parseSpanContext :: BS.ByteString -> Maybe SpanContext+parseSpanContext input =+  case BS.split '-' input of+    ["00", (fromHex -> Just tid), (fromHex -> Just sid), _] ->+      Just $ SpanContext (SId sid) (TId tid)+    _ -> Nothing++renderSpanContext :: SpanContext -> BS.ByteString+renderSpanContext (SpanContext (SId sid) (TId tid)) =+  BS.pack $ printf "00-%x-%x-00" tid sid++isLowerHexDigit (ord -> w) = (w >= 48 && w <= 57) || (w >= 97 && w <= 102)++fromHex :: BS.ByteString -> Maybe Word64+fromHex bytes = BS.foldl' go (Just 0) bytes+  where+    go Nothing _ = Nothing+    go (Just !result) (ord -> d) | d >= 48 && d < 58 = Just $ result * 16 + fromIntegral d - 48+    go (Just result) (ord -> d) | d >= 97 && d < 124 = Just $ result * 16 + fromIntegral d - 87+    go _ _ = Nothing

@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module TestPropagation where++import qualified Data.ByteString.Char8 as BS+import Data.Word+import OpenTelemetry.Common+import OpenTelemetry.Propagation+import Test.Tasty.HUnit+import Text.Printf++prop_render_parse_roundtrip :: Word64 -> Word64 -> Bool+prop_render_parse_roundtrip sid tid =+  let c = SpanContext (SId sid) (TId tid)+   in Just c == extractSpanContextFromHeaders [("traceparent", renderSpanContext c)]++unit_render_smoke =+  renderSpanContext (SpanContext (SId 1) (TId 2)) @?= "00-2-1-00"++unit_parse_smoke =+  extractSpanContextFromHeaders [("traceparent", "00-2-1-00")] @?= Just (SpanContext (SId 1) (TId 2))++prop_fromHex :: Word64 -> Bool+prop_fromHex x =+  Just x == fromHex (BS.pack $ printf "%x" x)++unit_fromHex_smoke =+  Just 1 @?= fromHex "1"