diff --git a/app/ZipkinExample.hs b/app/ZipkinExample.hs --- a/app/ZipkinExample.hs +++ b/app/ZipkinExample.hs @@ -10,17 +10,17 @@ import UnliftIO.Concurrent (forkIO, threadDelay) example :: (MonadTrace m, MonadUnliftIO m) => m () -example = ZPK.rootSpan ZPK.Accept "something" $ do +example = rootSpan alwaysSampled "something" $ do ZPK.tag "tag.key1" "a tag value" threadDelay 100000 - ZPK.localSpan "nested1" $ do - void $ forkIO $ ZPK.localSpan "concurrent" $ do + childSpan "nested1" $ do + void $ forkIO $ childSpan "concurrent" $ do threadDelay 20000 ZPK.tag "tag.key2" "another tag value" ZPK.annotate "launched concurrent" threadDelay 10000 ZPK.annotate "nested1 ended" - ZPK.localSpan "nested2" $ threadDelay 30000 + childSpan "nested2" $ threadDelay 30000 main :: IO () -main = ZPK.with ZPK.defaultSettings $ flip ZPK.run example +main = ZPK.with ZPK.defaultSettings $ ZPK.run example diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -31,6 +31,7 @@ import Data.Maybe (fromMaybe) import Data.Time.Clock (NominalDiffTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import System.Random (randomRIO) import UnliftIO (MonadUnliftIO, UnliftIO(..), askUnliftIO, withRunInIO, withUnliftIO) -- | A collection of span tags. @@ -74,8 +75,19 @@ trace bldr (TraceT reader) = TraceT $ do parentScope <- ask let - mbParentCtx = spanContext <$> scopeSpan parentScope + mbParentSpn = scopeSpan parentScope + mbParentCtx = spanContext <$> mbParentSpn mbTraceID = contextTraceID <$> mbParentCtx + mbSampling = builderSampling bldr + isDebug = fromMaybe False $ ((== Debug) <$> mbSampling) <|> (spanIsDebug <$> mbParentSpn) + isSampled <- case mbSampling of + Just Debug -> pure True + Just Always -> pure True + Just Never -> pure False + Just (WithProbability r) -> do + r' <- liftIO $ randomRIO (0, 1) + pure $ r' < r + Nothing -> pure $ maybe False spanIsSampled mbParentSpn spanID <- maybe (liftIO randomSpanID) pure $ builderSpanID bldr traceID <- maybe (liftIO randomTraceID) pure $ builderTraceID bldr <|> mbTraceID tagsTV <- liftIO $ newTVarIO $ builderTags bldr @@ -83,7 +95,7 @@ let baggages = fromMaybe Map.empty $ contextBaggages <$> mbParentCtx ctx = Context traceID spanID (builderBaggages bldr `Map.union` baggages) - spn = Span (builderName bldr) ctx (builderReferences bldr) + spn = Span (builderName bldr) ctx (builderReferences bldr) isSampled isDebug tracer = scopeTracer parentScope childScope = Scope tracer (Just spn) (Just tagsTV) (Just logsTV) withRunInIO $ \run -> do diff --git a/src/Control/Monad/Trace/Class.hs b/src/Control/Monad/Trace/Class.hs --- a/src/Control/Monad/Trace/Class.hs +++ b/src/Control/Monad/Trace/Class.hs @@ -1,12 +1,21 @@ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | The 'MonadTrace' class module Control.Monad.Trace.Class ( + -- * Generating traces MonadTrace(..), - Builder(..), Name, SpanID, TraceID, Reference(..), builder, Span(..), Context(..), + TraceID(..), encodeTraceID, decodeTraceID, + SpanID(..), encodeSpanID, decodeSpanID, + Reference(..), + rootSpan, rootSpanWith, childSpan, childSpanWith, + -- * Customizing spans + Builder(..), Name, builder, + Sampling, alwaysSampled, neverSampled, sampledEvery, sampledWhen, debugEnabled, + -- * Annotating spans Key, Value, tagDoubleValue, tagInt64Value, tagTextValue, logValue, logValueAt ) where @@ -107,14 +116,67 @@ -- ^ Initial set of tags. , builderBaggages :: !(Map Key ByteString) -- ^ Span context baggages. + , builderSampling :: !(Maybe Sampling) + -- ^ How the span should be sampled. If unset, the active's span sampling will be used if present, + -- otherwise the span will not be sampled. } deriving Show -- | Returns a 'Builder' with the given input as name and all other fields empty. builder :: Name -> Builder -builder name = Builder name Nothing Nothing Set.empty Map.empty Map.empty +builder name = Builder name Nothing Nothing Set.empty Map.empty Map.empty Nothing instance IsString Builder where fromString = builder . T.pack + +-- | Returns a 'Sampling' which always samples. +alwaysSampled :: Sampling +alwaysSampled = Always + +-- | Returns a 'Sampling' which never samples. +neverSampled :: Sampling +neverSampled = Never + +-- | Returns a debug 'Sampling'. Debug spans are always sampled. +debugEnabled :: Sampling +debugEnabled = Debug + +-- | Returns a 'Sampling' which randomly samples one in every @n@ spans. +sampledEvery :: Int -> Sampling +sampledEvery n = WithProbability (1 / fromIntegral n) + +-- | Returns a 'Sampling' which samples a span iff the input is 'True'. +sampledWhen :: Bool -> Sampling +sampledWhen b = if b then Always else Never + +-- Generic span creation + +-- | Starts a new trace, customizing the span builder. Note that the sampling input will override +-- any sampling customization set on the builder. +rootSpanWith :: MonadTrace m => (Builder -> Builder) -> Sampling -> Name -> m a -> m a +rootSpanWith f sampling name = trace $ (f $ builder name) { builderSampling = Just sampling } + +-- | Starts a new trace. +rootSpan :: MonadTrace m => Sampling -> Name -> m a -> m a +rootSpan = rootSpanWith id + +-- | Extends a trace if it is active, otherwise do nothing. The active span's ID will be added as a +-- reference to the new span and it will share the same trace ID (overriding any customization done +-- to the builder). +childSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> m a -> m a +childSpanWith f name actn = activeSpan >>= \case + Nothing -> actn + Just spn -> do + let + ctx = spanContext spn + bldr = (f $ builder name) + bldr' = bldr + { builderTraceID = Just $ contextTraceID ctx + , builderReferences = Set.insert (ChildOf $ contextSpanID ctx) (builderReferences bldr) } + trace bldr' actn + +-- | Extends a trace if it is active, otherwise do nothing. +childSpan :: MonadTrace m => Name -> m a -> m a +childSpan = childSpanWith id -- Writing metadata diff --git a/src/Control/Monad/Trace/Internal.hs b/src/Control/Monad/Trace/Internal.hs --- a/src/Control/Monad/Trace/Internal.hs +++ b/src/Control/Monad/Trace/Internal.hs @@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Control.Monad.Trace.Internal ( - TraceID(..), randomTraceID, - SpanID(..), randomSpanID, + TraceID(..), encodeTraceID, decodeTraceID, randomTraceID, + SpanID(..), encodeSpanID, decodeSpanID, randomSpanID, Context(..), Name, Span(..), + Sampling(..), Reference(..), Key, Value(..) ) where @@ -34,13 +35,21 @@ -- | A 128-bit trace identifier. newtype TraceID = TraceID ByteString deriving (Eq, Ord, Show) +-- | Hex-encodes a trace ID. +encodeTraceID :: TraceID -> Text +encodeTraceID (TraceID bs) = hexEncode bs + +-- | Decodes a traced ID from a hex-encoded string. +decodeTraceID :: Text -> Maybe TraceID +decodeTraceID txt = case hexDecode txt of + Just bs | BS.length bs == 16 -> Just $ TraceID bs + _ -> Nothing + instance JSON.FromJSON TraceID where - parseJSON = JSON.withText "TraceID" $ \t -> case hexDecode t of - Just bs | BS.length bs == 16 -> pure $ TraceID bs - _ -> fail "invalid hex-encoded trace ID" + parseJSON = JSON.withText "TraceID" $ maybe (fail "invalid hex-encoding") pure . decodeTraceID instance JSON.ToJSON TraceID where - toJSON (TraceID bs) = JSON.toJSON $ hexEncode bs + toJSON = JSON.toJSON . encodeTraceID -- | Generates a random trace ID. randomTraceID :: IO TraceID @@ -49,13 +58,21 @@ -- | A 64-bit span identifier. newtype SpanID = SpanID ByteString deriving (Eq, Ord, Show) +-- | Hex-encodes a span ID. +encodeSpanID :: SpanID -> Text +encodeSpanID (SpanID bs) = hexEncode bs + +-- | Decodes a span ID from a hex-encoded string. +decodeSpanID :: Text -> Maybe SpanID +decodeSpanID txt = case hexDecode txt of + Just bs | BS.length bs == 8 -> Just $ SpanID bs + _ -> Nothing + instance JSON.FromJSON SpanID where - parseJSON = JSON.withText "SpanID" $ \t -> case hexDecode t of - Just bs | BS.length bs == 8 -> pure $ SpanID bs - _ -> fail "invalid hex-encoded span ID" + parseJSON = JSON.withText "SpanID" $ maybe (fail "invalid hex-encoding") pure . decodeSpanID instance JSON.ToJSON SpanID where - toJSON (SpanID bs) = JSON.toJSON $ hexEncode bs + toJSON = JSON.toJSON . encodeSpanID -- | Generates a random span ID. randomSpanID :: IO SpanID @@ -93,7 +110,17 @@ { spanName :: !Name , spanContext :: !Context , spanReferences :: !(Set Reference) + , spanIsSampled :: !Bool + , spanIsDebug :: !Bool } + +-- | A trace sampling strategy. +data Sampling + = Always + | Never + | Debug + | WithProbability Double + deriving (Eq, Show) randomID :: Int -> IO ByteString randomID len = BS.pack <$> replicateM len randomIO diff --git a/src/Monitor/Tracing.hs b/src/Monitor/Tracing.hs --- a/src/Monitor/Tracing.hs +++ b/src/Monitor/Tracing.hs @@ -1,42 +1,45 @@ {-| Non-intrusive distributed tracing -Let's assume for example we are interested in tracing the two following functions and publishing -their traces to Zipkin: +Let's assume for example we are interested in tracing the two following functions: -> listTaskIDs :: MonadIO m => m [Int] -- Returns a list of all task IDs. -> fetchTasks :: MonadIO m => [Int] -> m [Task] -- Resolves IDs into tasks. +> listTaskIDs' :: MonadIO m => m [Int] -- Returns a list of all task IDs. +> fetchTasks' :: MonadIO m => [Int] -> m [Task] -- Resolves IDs into tasks. -We can do so simply by wrapping them inside a 'Monitor.Tracing.Zipkin.localSpan' call and adding a -'MonadTrace' constraint: +We can do so simply by wrapping them inside a 'childSpan' call and adding a 'MonadTrace' constraint: -> listTaskIDs' :: (MonadIO m, MonadTrace m) => m [Int] -> listTaskIDs' = localSpan "list-task-ids" listTaskIDs +> import Monitor.Tracing > -> fetchTasks' :: (MonadIO m, MonadTrace m) => [Int] -> m [Task] -> fetchTasks' = localSpan "fetch-tasks" . fetchTasks +> listTaskIDs :: (MonadIO m, MonadTrace m) => m [Int] +> listTaskIDs = childSpan "list-task-ids" listTaskIDs' +> +> fetchTasks :: (MonadIO m, MonadTrace m) => [Int] -> m [Task] +> fetchTasks = childSpan "fetch-tasks" . fetchTasks' -Spans will now automatically get generated and published each time these actions are run! Each -publication will include various useful pieces of metadata, including lineage. For example, if we -wrap the two above functions in a root span, the spans will correctly be nested: +Spans will now automatically get generated any time these actions are run! Each span will be +associated with various useful pieces of metadata, including lineage. For example, if we wrap the +two above functions in a 'rootSpan', the spans will correctly be nested: -> main :: IO () -> main = do -> zipkin <- new defaultSettings -> tasks <- run zipkin $ rootSpan "list-tasks" (listTaskIDs' >>= fetchTasks') -> publish zipkin -> print tasks +> printTasks :: (MonadIO m, MonadTrace m) => m () +> printTasks = rootSpan alwaysSampled "list-tasks" $ listTaskIDs >>= fetchTasks >>= print -For clarity the above example imported all functions unqualified. In general, the recommended -pattern when using this library is to import this module unqualified and the backend-specific module -qualified. For example: +Spans can then be published to various backends. For example, to run the above action and publish +its spans using Zipkin: -> import Monitor.Tracing > import qualified Monitor.Tracing.Zipkin as ZPK +> +> main :: IO () +> main = ZPK.with ZPK.defaultSettings $ ZPK.run printTasks -} module Monitor.Tracing ( -- * Overview - MonadTrace + MonadTrace, + -- * Generic span creation + Sampling, alwaysSampled, neverSampled, sampledEvery, sampledWhen, debugEnabled, + rootSpan, rootSpanWith, childSpan, childSpanWith, + -- * Backends + Zipkin ) where import Control.Monad.Trace.Class +import Monitor.Tracing.Zipkin (Zipkin) diff --git a/src/Monitor/Tracing/Zipkin.hs b/src/Monitor/Tracing/Zipkin.hs --- a/src/Monitor/Tracing/Zipkin.hs +++ b/src/Monitor/Tracing/Zipkin.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-| trace publisher. -} @@ -9,10 +10,8 @@ Zipkin, new, Settings(..), defaultSettings, Endpoint(..), defaultEndpoint, run, publish, with, - -- * Record in-process spans - rootSpan, Sampling(..), localSpan, -- * Record cross-process spans - B3, clientSpan, serverSpan, producerSpan, consumerSpan, + B3, b3FromHeaders, b3ToHeaders, clientSpan, serverSpan, producerSpan, consumerSpan, -- * Add metadata tag, annotate, annotateAt ) where @@ -20,14 +19,12 @@ import Control.Monad.Trace import Control.Monad.Trace.Class -import Control.Applicative ((<|>)) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM (atomically, tryReadTChan) -import Control.Monad (forever, void, when) +import Control.Monad (forever, guard, void, when) import Control.Monad.Fix (fix) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Aeson as JSON -import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Time.Clock (NominalDiffTime) import Data.Foldable (toList) @@ -35,10 +32,9 @@ import Data.IORef (modifyIORef, newIORef, readIORef) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) +import Data.Maybe (catMaybes, listToMaybe, maybe, maybeToList) import Data.Monoid (Endo(..)) import Data.Set (Set) -import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock.POSIX (POSIXTime) @@ -83,7 +79,7 @@ fix $ \loop -> atomically (tryReadTChan $ tracerChannel tracer) >>= \case Nothing -> pure () Just (spn, tags, logs, itv) -> do - when (isSampled spn) $ modifyIORef ref (ZipkinSpan ept spn tags logs itv:) + when (spanIsSampled spn) $ modifyIORef ref (ZipkinSpan ept spn tags logs itv:) loop spns <- readIORef ref let req' = req { HTTP.requestBody = HTTP.RequestBodyLBS $ JSON.encode spns } @@ -110,8 +106,8 @@ -- | Runs a 'TraceT' action, sampling spans appropriately. Note that this method does not publish -- spans on its own; to do so, either call 'publish' manually or specify a positive -- 'settingsPublishPeriod' to publish in the background. -run :: Zipkin -> TraceT m a -> m a -run zipkin actn = runTraceT actn (zipkinTracer zipkin) +run :: TraceT m a -> Zipkin -> m a +run actn zipkin = runTraceT actn (zipkinTracer zipkin) -- | Flushes all complete spans to the Zipkin server. This method is thread-safe. publish :: MonadIO m => Zipkin -> m () @@ -141,24 +137,66 @@ { b3TraceID :: !TraceID , b3SpanID :: !SpanID , b3ParentSpanID :: !(Maybe SpanID) - , b3Sampling :: !(Maybe Sampling) + , b3IsSampled :: !Bool + , b3IsDebug :: !Bool } deriving (Eq, Show) +traceIDHeader, spanIDHeader, parentSpanIDHeader, sampledHeader, debugHeader :: Text +traceIDHeader = "X-B3-TraceId" +spanIDHeader = "X-B3-SpanId" +parentSpanIDHeader = "X-B3-ParentSpanId" +sampledHeader = "X-B3-Sampled" +debugHeader = "X-B3-Flags" + +-- | Serializes the 'B3' to headers, suitable for HTTP requests. +b3ToHeaders :: B3 -> Map Text Text +b3ToHeaders (B3 traceID spanID mbParentID isSampled isDebug) = + let + defaultKVs = [(traceIDHeader, encodeTraceID traceID), (spanIDHeader, encodeSpanID spanID)] + parentKVs = (parentSpanIDHeader,) . encodeSpanID <$> maybeToList mbParentID + sampledKVs = case (isSampled, isDebug) of + (_, True) -> [(debugHeader, "1")] + (True, _) -> [(sampledHeader, "1")] + (False, _) -> [(sampledHeader, "0")] + in Map.fromList $ defaultKVs ++ parentKVs ++ sampledKVs + +-- | Deserializes the 'B3' from headers. +b3FromHeaders :: Map Text Text -> Maybe B3 +b3FromHeaders hdrs = do + let + find key = Map.lookup key hdrs + findBool def key = case find key of + Nothing -> Just def + Just "1" -> Just True + Just "0" -> Just False + _ -> Nothing + dbg <- findBool False debugHeader + sampled <- findBool dbg sampledHeader + guard (not $ sampled == False && dbg) + B3 + <$> (find traceIDHeader >>= decodeTraceID) + <*> (find spanIDHeader >>= decodeSpanID) + <*> maybe (pure Nothing) (Just <$> decodeSpanID) (find parentSpanIDHeader) + <*> pure sampled + <*> pure dbg + +instance JSON.FromJSON B3 where + parseJSON = JSON.withObject "B3" $ \v -> do + hdrs <- JSON.parseJSON (JSON.Object v) + maybe (fail "bad input") pure $ b3FromHeaders hdrs + +instance JSON.ToJSON B3 where + toJSON = JSON.toJSON . b3ToHeaders + b3FromSpan :: Span -> B3 b3FromSpan s = let ctx = spanContext s - samplingState = if fromMaybe False (lookupBoolBaggage debugKey ctx) - then Just Debug - else explicitSamplingState <$> lookupBoolBaggage samplingKey ctx - in B3 (contextTraceID ctx) (contextSpanID ctx) (parentID $ spanReferences s) samplingState + refs = spanReferences s + in B3 (contextTraceID ctx) (contextSpanID ctx) (parentID refs) (spanIsSampled s) (spanIsDebug s) -- Builder endos -insertBaggage :: Key -> ByteString -> Endo Builder -insertBaggage key val = - Endo $ \bldr -> bldr { builderBaggages = Map.insert key val (builderBaggages bldr) } - insertTag :: JSON.ToJSON a => Key -> a -> Endo Builder insertTag key val = Endo $ \bldr -> bldr { builderTags = Map.insert key (JSON.toJSON val) (builderTags bldr) } @@ -166,50 +204,17 @@ importB3 :: B3 -> Endo Builder importB3 b3 = let - baggages = Map.fromList $ case b3Sampling b3 of - Just Accept -> [(samplingKey, "1")] - Just Deny -> [(samplingKey, "0")] - Just Debug -> [(debugKey, "1")] - Nothing -> [] + sampling = if b3IsDebug b3 + then debugEnabled + else sampledWhen $ b3IsSampled b3 in Endo $ \bldr -> bldr { builderTraceID = Just (b3TraceID b3) , builderSpanID = Just (b3SpanID b3) - , builderBaggages = baggages } - --- | The sampling applied to a trace. --- --- Note that non-sampled traces still yield active spans. However these spans are not published to --- Zipkin. -data Sampling - = Accept - -- ^ Sample it. - | Debug - -- ^ Sample it and mark it as debug. - | Deny - -- ^ Do not sample it. - deriving (Eq, Ord, Enum, Show) - -applySampling :: Sampling -> Endo Builder -applySampling Accept = insertBaggage samplingKey "1" -applySampling Debug = insertBaggage debugKey "1" -applySampling Deny = insertBaggage samplingKey "0" - -isSampled :: Span -> Bool -isSampled spn = - let ctx = spanContext spn - in fromMaybe False $ lookupBoolBaggage debugKey ctx <|> lookupBoolBaggage samplingKey ctx + , builderSampling = Just sampling } publicKeyPrefix :: Text publicKeyPrefix = "Z." --- Debug baggage key. -debugKey :: Key -debugKey = "z.d" - --- Sampling baggage key. -samplingKey :: Key -samplingKey = "z.s" - -- Remote endpoint tag key. endpointKey :: Key endpointKey = "z.e" @@ -220,35 +225,20 @@ -- Internal keys --- | Starts a new trace. -rootSpan :: MonadTrace m => Sampling -> Name -> m a -> m a -rootSpan sampling name = trace $ appEndo (applySampling sampling) $ builder name - -childSpan :: MonadTrace m => Endo Builder -> Name -> m a -> m a -childSpan endo name actn = activeSpan >>= \case - Nothing -> actn - Just spn -> do - let - ctx = spanContext spn - bldr = (builder name) - { builderTraceID = Just $ contextTraceID ctx - , builderReferences = Set.singleton (ChildOf $ contextSpanID ctx) } - trace (appEndo endo $ bldr) actn - --- | Continues an existing trace if present, otherwise does nothing. -localSpan :: MonadTrace m => Name -> m a -> m a -localSpan = childSpan mempty - outgoingSpan :: MonadTrace m => Text -> Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a -outgoingSpan kind mbEpt name f = childSpan endo name actn where +outgoingSpan kind mbEpt name f = childSpanWith (appEndo endo) name actn where endo = insertTag kindKey kind <> maybe mempty (insertTag endpointKey) mbEpt actn = activeSpan >>= \case Nothing -> f Nothing Just spn -> f $ Just $ b3FromSpan spn +-- | Generates a child span with @CLIENT@ kind. This function also provides the corresponding 'B3' +-- so that it can be forwarded to the server. clientSpan :: MonadTrace m => Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a clientSpan = outgoingSpan "CLIENT" +-- | Generates a child span with @PRODUCER@ kind. This function also provides the corresponding 'B3' +-- so that it can be forwarded to the consumer. producerSpan :: MonadTrace m => Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a producerSpan = outgoingSpan "PRODUCER" @@ -259,9 +249,11 @@ bldr = appEndo endo $ builder "" in trace bldr actn +-- | Generates a child span with @SERVER@ kind. The client's 'B3' should be provided as input. serverSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a serverSpan = incomingSpan "SERVER" +-- | Generates a child span with @CONSUMER@ kind. The producer's 'B3' should be provided as input. consumerSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a consumerSpan = incomingSpan "CONSUMER" @@ -284,55 +276,11 @@ , ("ipv4" JSON..=) <$> mbIPv4 , ("ipv6" JSON..=) <$> mbIPv6 ] -explicitSamplingState :: Bool -> Sampling -explicitSamplingState True = Accept -explicitSamplingState False = Deny - -lookupBoolBaggage :: Key -> Context -> Maybe Bool -lookupBoolBaggage key ctx = Map.lookup key (contextBaggages ctx) >>= \case - "0" -> Just False - "1" -> Just True - _ -> Nothing - parentID :: Set Reference -> Maybe SpanID parentID = listToMaybe . catMaybes . fmap go . toList where go (ChildOf d) = Just d go _ = Nothing -traceIDHeader, spanIDHeader, parentSpanIDHeader, sampledHeader, debugHeader :: Text -traceIDHeader = "X-B3-TraceId" -spanIDHeader = "X-B3-SpanId" -parentSpanIDHeader = "X-B3-ParentSpanId" -sampledHeader = "X-B3-Sampled" -debugHeader = "X-B3-Flags" - -instance JSON.FromJSON B3 where - parseJSON = JSON.withObject "B3" $ \v -> do - dbg <- v JSON..:! debugHeader JSON..!= False - state <- fmap explicitSamplingState <$> v JSON..:! sampledHeader - let - sampling = case (dbg, state) of - (False, s) -> pure s - (True, Nothing) -> pure (Just Debug) - _ -> fail "bad debug and sampling combination" - B3 - <$> v JSON..: traceIDHeader - <*> v JSON..: spanIDHeader - <*> v JSON..:! parentSpanIDHeader - <*> sampling - -instance JSON.ToJSON B3 where - toJSON (B3 traceID spanID mbParentID state) = - let - defaultKVs = [traceIDHeader JSON..= traceID, spanIDHeader JSON..= spanID] - parentKVs = (parentSpanIDHeader JSON..=) <$> maybeToList mbParentID - sampledKVs = case state of - Nothing -> [] - Just Debug -> [debugHeader JSON..= ("1" :: Text)] - Just Accept -> [sampledHeader JSON..= ("1" :: Text)] - Just Deny -> [sampledHeader JSON..= ("0" :: Text)] - in JSON.object $ defaultKVs ++ parentKVs ++ sampledKVs - data ZipkinAnnotation = ZipkinAnnotation !POSIXTime !JSON.Value instance JSON.ToJSON ZipkinAnnotation where @@ -360,7 +308,7 @@ , "id" JSON..= contextSpanID ctx , "timestamp" JSON..= microSeconds @Int64 (intervalStart itv) , "duration" JSON..= microSeconds @Int64 (intervalDuration itv) - , "debug" JSON..= fromMaybe False (lookupBoolBaggage debugKey ctx) + , "debug" JSON..= spanIsDebug spn , "tags" JSON..= publicTags tags , "annotations" JSON..= fmap (\(t, _, v) -> ZipkinAnnotation t v) logs ] optionalKVs = catMaybes diff --git a/tracing.cabal b/tracing.cabal --- a/tracing.cabal +++ b/tracing.cabal @@ -1,5 +1,5 @@ name: tracing -version: 0.0.1.2 +version: 0.0.2.0 synopsis: Distributed tracing description: https://github.com/mtth/tracing homepage: https://github.com/mtth/tracing