tracing 0.0.1.2 → 0.0.2.0
raw patch · 7 files changed
+218/−166 lines, 7 files
Files
- app/ZipkinExample.hs +5/−5
- src/Control/Monad/Trace.hs +14/−2
- src/Control/Monad/Trace/Class.hs +64/−2
- src/Control/Monad/Trace/Internal.hs +37/−10
- src/Monitor/Tracing.hs +27/−24
- src/Monitor/Tracing/Zipkin.hs +70/−122
- tracing.cabal +1/−1
app/ZipkinExample.hs view
@@ -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
src/Control/Monad/Trace.hs view
@@ -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
src/Control/Monad/Trace/Class.hs view
@@ -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
src/Control/Monad/Trace/Internal.hs view
@@ -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
src/Monitor/Tracing.hs view
@@ -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)
src/Monitor/Tracing/Zipkin.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-| <https://zipkin.apache.org/ Zipkin> 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
tracing.cabal view
@@ -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