diff --git a/app/ZipkinExample.hs b/app/ZipkinExample.hs --- a/app/ZipkinExample.hs +++ b/app/ZipkinExample.hs @@ -4,13 +4,14 @@ module Main where import Control.Monad (void) +import Control.Monad.Trace.Class (rootSpanWith) import Monitor.Tracing import qualified Monitor.Tracing.Zipkin as ZPK import UnliftIO (MonadUnliftIO, liftIO) import UnliftIO.Concurrent (forkIO, threadDelay) example :: (MonadTrace m, MonadUnliftIO m) => m () -example = rootSpan alwaysSampled "something" $ do +example = rootSpanWith (ZPK.addInheritedTag "id" "1234") alwaysSampled "something" $ do ZPK.tag "tag.key1" "a tag value" threadDelay 100000 childSpan "nested1" $ 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 @@ -5,17 +5,22 @@ -- | This module exposes the generic 'MonadTrace' class. module Control.Monad.Trace.Class ( - -- * Generating traces - MonadTrace(..), + -- * Types Span(..), Context(..), - TraceID(..), encodeTraceID, decodeTraceID, - SpanID(..), encodeSpanID, decodeSpanID, + TraceID(..), decodeTraceID, encodeTraceID, + SpanID(..), decodeSpanID, encodeSpanID, Reference(..), - rootSpan, rootSpanWith, childSpan, childSpanWith, - -- * Customizing spans + + -- * Generating traces + -- ** Individual spans + MonadTrace(..), Builder(..), Name, builder, + -- ** Structured traces + rootSpan, rootSpanWith, childSpan, childSpanWith, + -- ** Sampling Sampling, alwaysSampled, neverSampled, sampledEvery, sampledWhen, debugEnabled, - -- * Annotating spans + + -- * Annotating traces -- | Note that not all annotation types are supported by all backends. For example Zipkin only -- supports string tags (refer to "Monitor.Tracing.Zipkin" for the full list of supported span -- metadata). @@ -46,7 +51,7 @@ import qualified Data.Text as T import Data.Time.Clock.POSIX (POSIXTime) --- | A monad capable of generating traces. +-- | A monad capable of generating and modifying trace spans. -- -- There are currently two instances of this monad: -- @@ -100,10 +105,10 @@ -- Creating traces --- | A trace builder. +-- | A span builder. -- --- Note that 'Builder' has an 'IsString' instance, producing a span with the given string as name, --- no additional references, tags, or baggages. This allows convenient creation of spans via the +-- 'Builder' has an 'IsString' instance, producing a span with the given string as name, no +-- additional references, tags, or baggages. This allows convenient creation of spans via the -- @OverloadedStrings@ pragma. data Builder = Builder { builderName :: !Name @@ -145,7 +150,7 @@ -- | Returns a 'Sampling' which randomly samples one in every @n@ spans. sampledEvery :: Int -> Sampling -sampledEvery n = WithProbability (1 / fromIntegral n) +sampledEvery n = WithProbability $ 1 / fromIntegral n -- | Returns a 'Sampling' which samples a span iff the input is 'True'. It is equivalent to: -- @@ -164,22 +169,21 @@ 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). +-- | Extends a trace, same as 'childSpan' but also customizing 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 = 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. +-- | Extends a trace: the active span's ID will be added as a reference to a newly created span and +-- both spans will share the same trace ID. If no span is active, 'childSpan' is a no-op. childSpan :: MonadTrace m => Name -> m a -> m a childSpan = childSpanWith id diff --git a/src/Monitor/Tracing.hs b/src/Monitor/Tracing.hs --- a/src/Monitor/Tracing.hs +++ b/src/Monitor/Tracing.hs @@ -44,7 +44,7 @@ -- | By default, traces created by 'trace' are independent from each other. However, we can get a -- lot more value out of tracing by organizing a trace's spans. The simplest and most common -- approach is to build a tree of spans, with a single root span and zero or more children for - -- each span. 'rootSpan' and 'childSpan' below set up spans such that the lineage of spans is + -- each span. 'rootSpan' and 'childSpan' below set up spans such that lineage information is -- automatically propagated. rootSpan, childSpan, 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 @@ -25,7 +25,11 @@ clientSpan, serverSpan, producerSpan, consumerSpan, -- * Custom metadata - tag, annotate, annotateAt + -- ** Tags + tag, addTag, addInheritedTag, + -- ** Annotations + -- | Annotations are similar to tags, but timestamped. + annotate, annotateAt ) where import Control.Monad.Trace @@ -149,6 +153,30 @@ tag :: MonadTrace m => Text -> Text -> m () tag key val = addSpanEntry (publicKeyPrefix <> key) (tagTextValue val) +-- | Adds a tag to a builder. This is a convenience method to use with 'childSpanWith', for example: +-- +-- > childSpanWith (addTag "key" "value") "run" $ action +-- +-- Note that there is not difference with adding the tag after the span. So the above code is +-- equivalent to: +-- +-- > childSpan "run" $ tag "key" "value" >> action +addTag :: Text -> Text -> Builder -> Builder +addTag key val bldr = bldr { builderTags = Map.insert key (JSON.toJSON val) (builderTags bldr) } + +-- | Adds an inherited tag to a builder. Unlike a tag added via 'addTag', this tag: +-- +-- * will be inherited by all the span's children. +-- * can only be added at span construction time. +-- +-- For example, to add an ID tag to all spans inside a trace: +-- +-- > rootSpanWith (addInheritedTag "id" "abcd-efg") alwaysSampled "run" $ action +addInheritedTag :: Text -> Text -> Builder -> Builder +addInheritedTag key val bldr = + let bgs = builderBaggages bldr + in bldr { builderBaggages = Map.insert key (T.encodeUtf8 val) bgs } + -- | Annotates the active span using the current time. annotate :: MonadTrace m => Text -> m () annotate val = addSpanEntry "" (logValue val) @@ -375,7 +403,7 @@ , "timestamp" JSON..= microSeconds @Int64 (intervalStart itv) , "duration" JSON..= microSeconds @Int64 (intervalDuration itv) , "debug" JSON..= spanIsDebug spn - , "tags" JSON..= publicTags tags + , "tags" JSON..= (publicTags tags <> (JSON.toJSON . T.decodeUtf8 <$> contextBaggages ctx)) , "annotations" JSON..= fmap (\(t, _, v) -> ZipkinAnnotation t v) logs ] optionalKVs = catMaybes [ ("parentId" JSON..=) <$> parentID (spanReferences spn) diff --git a/tracing.cabal b/tracing.cabal --- a/tracing.cabal +++ b/tracing.cabal @@ -1,12 +1,12 @@ name: tracing -version: 0.0.2.3 +version: 0.0.2.4 synopsis: Distributed tracing description: An OpenTracing-compliant, simple, and extensible distributed tracing library. homepage: https://github.com/mtth/tracing license: BSD3 license-file: LICENSE author: Matthieu Monsch -maintainer: matthieu.monsch@gmail.com +maintainer: mtth@apache.org copyright: 2019 Matthieu Monsch category: Web build-type: Simple @@ -40,11 +40,10 @@ ghc-options: -Wall test-suite tracing-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: - test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.8 && <5 , containers >= 0.6 , hspec >=2.6 @@ -53,7 +52,7 @@ , text >= 1.2 , tracing , unliftio >= 0.2 - default-language: Haskell2010 + default-language: Haskell2010 executable zipkin-example hs-source-dirs: app