packages feed

opentelemetry 0.2.0 → 0.3.0

raw patch · 15 files changed

+162/−573 lines, 15 filesdep −asyncdep −clockdep −directorydep ~basesetup-changed

Dependencies removed: async, clock, directory, hashable, opentelemetry, random, stm, tasty, tasty-discover, tasty-hunit, tasty-quickcheck, text, unordered-containers

Dependency ranges changed: base

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− just-some-usage-code-that-must-compile/Main.hs 
@@ -1,2 +0,0 @@-main :: IO ()-main = putStrLn "All done"
− just-some-usage-code-that-must-compile/SomeUsageOfImplicitApi.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}--module SomeUsageOfImplicitApi where--import Control.Concurrent-import Control.Concurrent.Async-import Control.Monad-import OpenTelemetry.Common-import OpenTelemetry.FileExporter-import OpenTelemetry.Implicit--main :: IO ()-main = do-  exporter <- createFileSpanExporter "helloworld.trace"-  let otConfig =-        OpenTelemetryConfig-          { otcSpanExporter = exporter-          }-  withOpenTelemetry otConfig $ do-    result <- pieceOfSeriousBusinessLogic 42-    print result--pieceOfSeriousBusinessLogic :: Int -> IO Int-pieceOfSeriousBusinessLogic input = withSpan "serious business" $ do-  let result = 2 * input-  -- setTag is value-polymorphic--  -- setTag "input" input -- Int (inferred)-  -- setTag @Int "result" result -- Int (explicit)-  -- setTag @String "seriousness" "serious" -- literals are polymorphic under OverloadedStrings so we need to annotate-  -- setTag @Double "profit" 99 -- numeric literals are also polymorphic-  -- setTag "error" False -- Bool literals are not polymorphic-  -- setTag @Int "largest integer below 100" 99 -- Int (inferred)--  -- TODO: JSON values--  addEvent "log" "rpc roundtrip begin"-  withSpan "leveraging synergies" $ do-    threadDelay 10000-    addEvent "log" "enough synergies leveraged"-  addEvent "log" "All your base are belong to us"-  addEvent "log" "rpc roundtrip end"-  withSpan "project" $ do-    -- Connecting spans across threads requires some manual plumbing-    Just sp <- getCurrentActiveSpan-    asyncWork <- async $ withChildSpanOf sp "data science" $ do-      threadDelay 1000000-      pure 42-    -- Doing a withSpan inside a loop is fine-    forM_ [input .. input + 10] $ \i -> withSpan "sprint" $ do-      -- setTag "week" i-      threadDelay 10000-    wait asyncWork-  pure result
opentelemetry.cabal view
@@ -2,7 +2,7 @@ name:                opentelemetry description:         The OpenTelemetry Haskell Client https://opentelemetry.io category:            OpenTelemetry-version:             0.2.0+version:             0.3.0 license-file:        LICENSE license:             Apache-2.0 author:              Dmitry Ivanov@@ -41,7 +41,6 @@     -Wincomplete-record-updates     -Wincomplete-uni-patterns     -Wpartial-fields-    -Wredundant-constraints     -fhide-source-paths     -ferror-spans     -freverse-errors@@ -49,49 +48,12 @@ library   import: options   build-depends:-    base >= 4.12 && < 5,+    base >= 4.11 && < 5,     bytestring,-    clock >= 0.8,-    directory,-    exceptions,-    hashable,-    random >= 1.1,-    stm,-    text,-    unordered-containers+    exceptions   hs-source-dirs: src   exposed-modules:-    OpenTelemetry.Common-    OpenTelemetry.Debug-    OpenTelemetry.FileExporter-    OpenTelemetry.Implicit+    OpenTelemetry.SpanContext+    OpenTelemetry.Exporter     OpenTelemetry.Propagation--test-suite just-some-usage-code-that-must-compile-  import: options-  type:       exitcode-stdio-1.0-  main-is:    Main.hs-  other-modules:-    SomeUsageOfImplicitApi-  hs-source-dirs: just-some-usage-code-that-must-compile-  build-depends:-    base,-    async,-    opentelemetry--test-suite unit-tests-  import: options-  type:       exitcode-stdio-1.0-  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+    OpenTelemetry.Eventlog
− src/OpenTelemetry/Common.hs 
@@ -1,153 +0,0 @@-{-# 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-import Data.Word-import System.Clock-import Text.Printf--newtype TraceId = TId Word64-  deriving (Eq, Generic)-  deriving (Hashable) via Word64--instance Show TraceId where-  show (TId tid) = printf "TraceId %x" tid--newtype SpanId = SId Word64-  deriving (Eq, Generic)-  deriving (Hashable) via Word64--instance Show SpanId where-  show (SId sid) = printf "SpanId %x" sid--type Timestamp = Word64--data Tracer threadId-  = Tracer-      { tracerSpanStacks :: !(HM.HashMap threadId (NE.NonEmpty Span))-      }-      deriving (Eq, Show)--tracerPushSpan :: (Eq tid, Hashable tid) => Tracer tid -> tid -> Span -> Tracer tid-tracerPushSpan t@(Tracer {..}) tid sp =-  case HM.lookup tid tracerSpanStacks of-    Nothing ->-      let !stacks = HM.insert tid (sp :| []) tracerSpanStacks-      in Tracer stacks-    Just sps ->-      let !stacks = HM.insert tid (sp <| sps) tracerSpanStacks-      in t { tracerSpanStacks = stacks }--tracerPopSpan :: (Eq tid, Hashable tid) => Tracer tid -> tid -> (Maybe Span, Tracer tid)-tracerPopSpan t@(Tracer {..}) tid =-  case HM.lookup tid tracerSpanStacks of-    Nothing -> (Nothing, t)-    Just (sp :| sps) ->-      let stacks =-            case NE.nonEmpty sps of-              Nothing -> HM.delete tid tracerSpanStacks-              Just sps' -> HM.insert tid sps' tracerSpanStacks-       in (Just sp, Tracer stacks)--tracerGetCurrentActiveSpan :: (Hashable tid, Eq tid) => Tracer tid -> tid -> Maybe Span-tracerGetCurrentActiveSpan (Tracer stacks) tid =-  case HM.lookup tid stacks of-    Nothing -> Nothing-    Just (sp NE.:| _) -> Just sp--createTracer :: (Hashable tid, Eq tid) => IO (Tracer tid)-createTracer = pure $ Tracer mempty--data SpanContext = SpanContext !SpanId !TraceId-  deriving (Show, Eq, Generic)--data TagValue-  = StringTagValue !T.Text-  | BoolTagValue !Bool-  | IntTagValue !Int-  | DoubleTagValue !Double-  deriving (Eq, Show)--class ToTagValue a where-  toTagValue :: a -> TagValue--instance ToTagValue String where-  toTagValue = StringTagValue . T.pack--instance ToTagValue T.Text where-  toTagValue = StringTagValue--instance ToTagValue Bool where-  toTagValue = BoolTagValue--instance ToTagValue Int where-  toTagValue = IntTagValue--data Span-  = Span-      { spanContext :: {-# UNPACK #-} !SpanContext,-        spanOperation :: T.Text,-        spanStartedAt :: !Timestamp,-        spanFinishedAt :: !Timestamp,-        spanTags :: !(HM.HashMap T.Text TagValue),-        spanEvents :: [SpanEvent],-        spanStatus :: !SpanStatus,-        spanParentId :: Maybe SpanId-      }-  deriving (Show, Eq)--spanTraceId :: Span -> TraceId-spanTraceId Span {spanContext = SpanContext _ tid} = tid--spanId :: Span -> SpanId-spanId Span {spanContext = SpanContext sid _} = sid--data SpanEvent = SpanEvent-  { spanEventTimestamp :: !Timestamp-  , spanEventKey :: !T.Text-  , spanEventValue :: !T.Text-  } deriving (Show, Eq)--data SpanStatus = OK-  deriving (Show, Eq)--data Event-  = Event T.Text Timestamp-  deriving (Show, Eq)--data SpanProcessor-  = SpanProcessor-      { onStart :: Span -> IO (),-        onEnd :: Span -> IO ()-      }--data ExportResult-  = ExportSuccess-  | ExportFailedRetryable-  | ExportFailedNotRetryable-  deriving (Show, Eq)--data Exporter thing-  = Exporter-      { export :: [thing] -> IO ExportResult,-        shutdown :: IO ()-      }--data OpenTelemetryConfig-  = OpenTelemetryConfig-      { otcSpanExporter :: Exporter Span-      }--noopExporter :: Exporter whatever-noopExporter = Exporter (const (pure ExportFailedNotRetryable)) (pure ())--now64 :: IO Timestamp-now64 = do-  TimeSpec secs nsecs <- getTime Realtime-  pure $! fromIntegral secs * 1_000_000_000 + fromIntegral nsecs
− src/OpenTelemetry/Debug.hs 
@@ -1,21 +0,0 @@-module OpenTelemetry.Debug where--import Control.Concurrent.STM-import Control.Monad.IO.Class-import System.Environment-import System.IO-import System.IO.Unsafe--dd_ :: Show a => String -> a -> IO ()-dd_ = unsafePerformIO $-  lookupEnv "OPENTELEMETRY_DEBUG" >>= \case-    Nothing -> pure $ \_ _ -> pure ()-    Just "0" -> pure $ \_ _ -> pure ()-    Just "false" -> pure $ \_ _ -> pure ()-    _ -> pure $ \s thing -> liftIO $ do-      hPutStr stderr (s <> ": ")-      hPutStrLn stderr (show thing)-{-# NOINLINE dd_ #-}--inc :: Int -> TVar Int -> IO ()-inc amount counterVar = atomically $ modifyTVar counterVar (+ amount)
+ src/OpenTelemetry/Eventlog.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Eventlog where++import Control.Monad.Catch+import Control.Monad.IO.Class+import qualified Data.ByteString.Char8 as BS8+import Debug.Trace+import OpenTelemetry.SpanContext+import Text.Printf++-- TODO(divanov): replace traceEventIO with the bytestring based equivalent++beginSpan :: MonadIO m => String -> m ()+beginSpan operation = liftIO $ traceEventIO (printf "ot1 begin span %s" operation)++endSpan :: MonadIO m => m ()+endSpan = liftIO $ traceEventIO (printf "ot1 end span")++setTag :: MonadIO m => String -> BS8.ByteString -> m ()+setTag k v = liftIO $ traceEventIO (printf "ot1 set tag %s %s" k (BS8.unpack v))++addEvent :: MonadIO m => String -> BS8.ByteString -> m ()+addEvent k v = liftIO $ traceEventIO (printf "ot1 add event %s %s" k (BS8.unpack v))++setParentSpanContext :: MonadIO m => SpanContext -> m ()+setParentSpanContext (SpanContext (SId sid) (TId tid)) =+  liftIO $ traceEventIO (printf "ot1 set parent %016x %016x" tid sid)++setTraceId :: MonadIO m => TraceId -> m ()+setTraceId (TId tid) =+  liftIO $ traceEventIO (printf "ot1 set traceid %016x" tid)++setSpanId :: MonadIO m => SpanId -> m ()+setSpanId (SId sid) =+  liftIO $ traceEventIO (printf "ot1 set spanid %016x" sid)++withSpan :: forall m a. (MonadIO m, MonadMask m) => String -> m a -> m a+withSpan operation action =+  fst+    <$> generalBracket+      (liftIO $ beginSpan operation)+      ( \_span exitcase -> liftIO $ do+          case exitcase of+            ExitCaseSuccess _ -> pure ()+            ExitCaseException e -> do+              setTag "error" "true"+              setTag "error.message" (BS8.pack $ show e)+            ExitCaseAbort -> do+              setTag "error" "true"+              setTag "error.message" "abort"+          liftIO endSpan+      )+      (\_span -> action)
+ src/OpenTelemetry/Exporter.hs view
@@ -0,0 +1,16 @@+module OpenTelemetry.Exporter where++data ExportResult+  = ExportSuccess+  | ExportFailedRetryable+  | ExportFailedNotRetryable+  deriving (Show, Eq)++data Exporter thing+  = Exporter+      { export :: [thing] -> IO ExportResult,+        shutdown :: IO ()+      }++noopExporter :: Exporter whatever+noopExporter = Exporter (const (pure ExportFailedNotRetryable)) (pure ())
− src/OpenTelemetry/FileExporter.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module OpenTelemetry.FileExporter where--import Data.Function-import qualified Data.HashMap.Strict as HM-import Data.List-import qualified Data.Text as T-import OpenTelemetry.Common-import System.IO-import Text.Printf-import Text.Read--showValue :: TagValue -> String-showValue (StringTagValue s) = show s-showValue (IntTagValue i) = show i-showValue _ = "\"unknown\""--showSpan :: Span -> String-showSpan s@(Span {..}) =-  let (TId tid) = spanTraceId s-      threadId = case HM.lookup "thread_id" spanTags of-        Just (StringTagValue (T.stripPrefix "ThreadId " -> Just (readMaybe . T.unpack -> Just t))) -> t-        Just (IntTagValue t) -> t-        _ -> 1-      meta :: String-      meta =-        spanTags-          & HM.toList-          & map (\(k, v) -> ["\"", T.unpack k, "\":", showValue v])-          & ([printf "\"traceId\":\"%x\"" tid] :)-          & intersperse [","]-          & concat-          & concat-   in printf-        "{\"ph\":\"B\",\"name\":\"%s\",\"pid\":1,\"ts\":%d,\"tid\":%d,\"args\":{%s}},{\"ph\":\"E\",\"name\":\"%s\",\"pid\":1,\"ts\":%d,\"tid\":%d},"-        spanOperation-        (div spanStartedAt 1000)-        threadId-        meta-        spanOperation-        (div spanFinishedAt 1000)-        threadId--createFileSpanExporter :: FilePath -> IO (Exporter Span)-createFileSpanExporter path = do-  f <- openFile path WriteMode-  hPutStrLn f "["-  pure-    $! Exporter-      ( \sps -> do-          mapM_ (hPutStrLn f . showSpan) sps-          pure ExportSuccess-      )-      ( do-          hSeek f RelativeSeek (-2) -- overwrite the last comma-          hPutStrLn f "\n]"-          hClose f-      )
− src/OpenTelemetry/Implicit.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}--module OpenTelemetry.Implicit where--import Control.Concurrent-import Control.Monad.Catch-import Control.Monad.IO.Class-import qualified Data.HashMap.Strict as HM-import Data.List.NonEmpty (NonEmpty ((:|)))-import qualified Data.Text as T-import OpenTelemetry.Common-import OpenTelemetry.FileExporter-import System.Directory-import System.Environment-import System.IO.Unsafe-import System.Random-import Text.Printf--data SpanChildness = Root | ChildOf Span--data AutoTagError = DoAutoTagError | Don'tAutoTagError--withSpan :: (MonadIO m, MonadMask m) => String -> m a -> m a-withSpan = generalWithSpan (WithSpanOptions Root DoAutoTagError)--data WithSpanOptions-  = WithSpanOptions-      { childness :: SpanChildness,-        autoTagError :: AutoTagError-      }--generalWithSpan :: (MonadIO m, MonadMask m) => WithSpanOptions -> String -> m a -> m a-generalWithSpan WithSpanOptions {childness, autoTagError} operation action = do-  threadId <- liftIO myThreadId-  sid <- liftIO randomIO-  startedAt <- liftIO now64-  (result, ()) <--    generalBracket-      ( liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do-          let (!mpsid, !ctx) = case (childness, HM.lookup threadId (tracerSpanStacks gTracer)) of-                (ChildOf parent, _) -> (Just (spanId parent), SpanContext (SId sid) (spanTraceId parent))-                (_, Nothing) -> (Nothing, SpanContext (SId sid) (TId sid))-                (_, Just ((spanContext -> SpanContext psid tid) :| _)) -> (Just psid, SpanContext (SId sid) tid)-              !sp = Span ctx (T.pack operation) startedAt 0 (HM.singleton "thread_id" (StringTagValue $ T.pack $ show threadId)) mempty OK mpsid-              !tracer = tracerPushSpan gTracer threadId sp-          pure $! GlobalSharedMutableState gSpanExporter tracer-      )-      ( \_ exitcase -> do-          liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do-            let (mspan, tracer) = tracerPopSpan gTracer threadId-            case mspan of-              Nothing -> pure ()-              Just sp -> do-                finishedAt <- liftIO now64-                let sp' = case (exitcase, autoTagError) of-                      (ExitCaseSuccess {}, _) -> sp-                      (_, Don'tAutoTagError) -> sp-                      _ -> sp {spanTags = HM.insert "error" (BoolTagValue True) (spanTags sp)}-                res <- export gSpanExporter [sp' {spanFinishedAt = finishedAt}]-                case res of-                  ExportSuccess -> pure ()-                  _ -> error $ "exporting span failed: " <> show sp-            pure $! GlobalSharedMutableState gSpanExporter tracer-      )-      (\_ -> action)-  pure result--setTag :: forall value m. (MonadIO m, ToTagValue value) => T.Text -> value -> m ()-setTag k v =-  modifyCurrentSpan-    ( \sp ->-        sp {spanTags = HM.insert k (toTagValue v) (spanTags sp)}-    )--addEvent :: forall m. MonadIO m => T.Text -> T.Text -> m ()-addEvent name value = do-  now <- liftIO now64-  modifyCurrentSpan-    ( \sp ->-        sp {spanEvents = SpanEvent now name value : spanEvents sp}-    )--setParentSpanContext :: MonadIO m => SpanContext -> m ()-setParentSpanContext (SpanContext psid tid) =-  modifyCurrentSpan-    ( \sp ->-        sp-          { spanContext = SpanContext (spanId sp) tid,-            spanParentId = Just psid-          }-    )--withOpenTelemetry :: (MonadIO m, MonadMask m) => OpenTelemetryConfig -> m a -> m a-withOpenTelemetry OpenTelemetryConfig {..} action = do-  bracket-    ( liftIO $ do-        tracer <- createTracer-        modifyMVar_ globalSharedMutableState (\_ -> pure $ GlobalSharedMutableState otcSpanExporter tracer)-        pure ()-    )-    (\_ -> liftIO $ shutdown otcSpanExporter)-    (\_ -> action)--data GlobalSharedMutableState-  = GlobalSharedMutableState-      { gSpanExporter :: !(Exporter Span),-        gTracer :: !(Tracer ThreadId)-      }--withZeroConfigOpenTelemetry :: (MonadIO m, MonadMask m) => m a -> m a-withZeroConfigOpenTelemetry action = do-  (now, prog_name, tmp_dir) <- liftIO $ (,,) <$> now64 <*> getProgName <*> getTemporaryDirectory-  exporter <- liftIO $ createFileSpanExporter $ printf "%s/%s-%d.trace.json" tmp_dir prog_name now-  let otelConfig = OpenTelemetryConfig {otcSpanExporter = exporter}-  withOpenTelemetry otelConfig action--getCurrentSpanContext :: MonadIO m => m (Maybe SpanContext)-getCurrentSpanContext = do-  tid <- liftIO myThreadId-  GlobalSharedMutableState {..} <- liftIO $ readMVar globalSharedMutableState-  pure $ spanContext <$> tracerGetCurrentActiveSpan gTracer tid--getCurrentActiveSpan :: MonadIO m => m (Maybe Span)-getCurrentActiveSpan = do-  tid <- liftIO myThreadId-  GlobalSharedMutableState {..} <- liftIO $ readMVar globalSharedMutableState-  pure $ tracerGetCurrentActiveSpan gTracer tid--modifyCurrentSpan :: MonadIO m => (Span -> Span) -> m ()-modifyCurrentSpan f = liftIO $ do-  tid <- myThreadId-  modifyMVar_-    globalSharedMutableState-    ( \g@(GlobalSharedMutableState {..}) ->-        case HM.lookup tid (tracerSpanStacks gTracer) of-          Nothing -> pure g-          Just (sp :| sps) ->-            let !stacks = HM.insert tid (f sp :| sps) (tracerSpanStacks gTracer)-             in pure $! g {gTracer = gTracer {tracerSpanStacks = stacks}}-    )--withChildSpanOf :: (MonadIO m, MonadMask m) => Span -> String -> m a -> m a-withChildSpanOf parent operation action = generalWithSpan (WithSpanOptions (ChildOf parent) DoAutoTagError) operation action--globalSharedMutableState :: MVar GlobalSharedMutableState-globalSharedMutableState = unsafePerformIO $ do-  tracer <- createTracer-  newMVar (GlobalSharedMutableState noopExporter tracer)-{-# NOINLINE globalSharedMutableState #-}
src/OpenTelemetry/Propagation.hs view
@@ -1,50 +1,94 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}  -- This is an approximate implementation of https://www.w3.org/TR/trace-context  module OpenTelemetry.Propagation where -import Data.Word-import qualified Data.ByteString.Char8 as BS+import Control.Applicative+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8 import Data.Char (ord) import Data.List (find) import Data.String-import GHC.Generics-import OpenTelemetry.Common+import Data.Word+import OpenTelemetry.SpanContext import Text.Printf -data TraceParent = TraceParent Int Int-  deriving (Eq, Show, Generic)+data PropagationFormat = PropagationFormat+  { propagateFromHeaders :: forall key. (Semigroup key, IsString key, Eq key) => [(key, BS.ByteString)] -> Maybe SpanContext,+    propagateToHeaders :: forall key. (Semigroup key, IsString key, Eq key) => SpanContext -> [(key, BS.ByteString)]+  } -extractSpanContextFromHeaders :: (IsString key, Eq key) => [(key, BS.ByteString)] -> Maybe SpanContext-extractSpanContextFromHeaders headers =-  case find ((== "traceparent") . fst) headers of-    Just (_, (parseSpanContext -> mctx)) -> mctx-    _ -> Nothing+-- | (p1 <> p2) parses like p1, then p2 as a fallback. (p1 <> p2) injects like p1.+instance Semigroup PropagationFormat where+  PropagationFormat from1 to1 <> PropagationFormat from2 _to2 =+    let from headers = from1 headers <|> from2 headers+        to context = to1 context+     in PropagationFormat from to +w3cTraceContext :: PropagationFormat+w3cTraceContext = PropagationFormat from to+  where+    from headers =+      case find ((== "traceparent") . fst) headers of+        Just (_, (parseSpanContext -> mctx)) -> mctx+        _ -> Nothing+    to (SpanContext (SId sid) (TId tid)) =+      [("traceparent", BS8.pack $ printf "00-%x-%x-00" tid sid)]++b3 :: PropagationFormat+b3 = typical_opentracing_format_with_prefix "x-b3-"++otTracer :: PropagationFormat+otTracer = typical_opentracing_format_with_prefix "ot-tracer-"++typical_opentracing_format_with_prefix :: String -> PropagationFormat+typical_opentracing_format_with_prefix prefix = PropagationFormat from to+  where+    to (SpanContext (SId sid) (TId tid)) =+      [ (fromString prefix <> "traceid", encode_u64 tid),+        (fromString prefix <> "spanid", encode_u64 sid),+        (fromString prefix <> "sampled", "true")+      ]+    from headers =+      let traceidKey = fromString prefix <> "traceid"+          spanidKey = fromString prefix <> "spanid"+          go _ (Just tid, Just sid) = Just (tid, sid)+          go [] _ = Nothing+          go ((k, v) : xs) (tid, sid)+            | k == traceidKey = go xs (decode_u64 v, sid)+            | k == spanidKey = go xs (tid, decode_u64 v)+            | otherwise = go xs (tid, sid)+       in (\(t, s) -> SpanContext (SId s) (TId t)) <$> go headers (Nothing, Nothing)+ parseSpanContext :: BS.ByteString -> Maybe SpanContext parseSpanContext input =-  case BS.split '-' input of+  case BS8.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 :: Char -> Bool isLowerHexDigit (ord -> w) = (w >= 48 && w <= 57) || (w >= 97 && w <= 102)  fromHex :: BS.ByteString -> Maybe Word64-fromHex bytes = BS.foldl' go (Just 0) bytes+fromHex bytes = BS8.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 -data PropagationFormat = W3CTraceContext+encode_u64 :: Word64 -> BS.ByteString+encode_u64 x = BS8.pack (printf "%016x" x) -inject :: PropagationFormat -> SpanContext -> [(String, BS.ByteString)]-inject W3CTraceContext ctx = [("traceparent", renderSpanContext ctx)]+decode_u64 :: BS.ByteString -> Maybe Word64+decode_u64 bytes | BS.length bytes > 16 = Nothing+decode_u64 bytes = BS.foldl' go (Just 0) bytes+  where+    go Nothing _ = Nothing+    go (Just !result) d | d >= 48 && d < 58 = Just $ result * 16 + fromIntegral d - 48+    go (Just result) d | d >= 97 && d < 124 = Just $ result * 16 + fromIntegral d - 87+    go _ _ = Nothing
+ src/OpenTelemetry/SpanContext.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveGeneric #-}++module OpenTelemetry.SpanContext where++import Data.Word+import GHC.Generics+import Text.Printf++newtype TraceId = TId Word64+  deriving (Eq, Generic)++instance Show TraceId where+  show (TId tid) = printf "(TraceId 0x%x)" tid++newtype SpanId = SId Word64+  deriving (Eq, Generic)++instance Show SpanId where+  show (SId sid) = printf "(SpanId 0x%x)" sid++data SpanContext = SpanContext !SpanId !TraceId+  deriving (Show, Eq, Generic)
− unit-tests/Main.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
− unit-tests/TestCommon.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module TestCommon where--import Data.Word-import OpenTelemetry.Common--mkTestSpan :: Word64 -> Word64 -> Span-mkTestSpan sid tid =-  Span-    { spanContext = SpanContext (SId sid) (TId tid),-      spanStartedAt = 0,-      spanFinishedAt = 10,-      spanTags = mempty,-      spanEvents = mempty,-      spanStatus = OK,-      spanOperation = "foo",-      spanParentId = Nothing-    }--prop_tracer_push_does_something :: Word64 -> Word64 -> Int -> Bool-prop_tracer_push_does_something sid tid threadid =-  let tracer0 = Tracer mempty-      sp0 = mkTestSpan sid tid-      tracer1 = tracerPushSpan tracer0 threadid sp0-   in tracer0 /= tracer1--prop_tracer_push_pop :: Word64 -> Word64 -> Int -> Bool-prop_tracer_push_pop sid tid threadid =-  let tracer0 = Tracer mempty-      sp0 = mkTestSpan sid tid-      tracer1 = tracerPushSpan tracer0 threadid sp0-      (Just sp1, tracer2) = tracerPopSpan tracer1 threadid-   in tracer0 == tracer2 && sp0 == sp1
− unit-tests/TestPropagation.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}--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 @String [("traceparent", renderSpanContext c)]--unit_render_smoke :: Assertion-unit_render_smoke =-  renderSpanContext (SpanContext (SId 1) (TId 2)) @?= "00-2-1-00"--unit_parse_smoke :: Assertion-unit_parse_smoke =-  extractSpanContextFromHeaders @String [("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 :: Assertion-unit_fromHex_smoke =-  Just 1 @?= fromHex "1"