tracing 0.0.2.4 → 0.0.3.0
raw patch · 9 files changed
+212/−124 lines, 9 files
Files
- README.md +3/−3
- src/Control/Monad/Trace.hs +90/−47
- src/Control/Monad/Trace/Class.hs +32/−23
- src/Control/Monad/Trace/Internal.hs +14/−9
- src/Monitor/Tracing.hs +7/−5
- src/Monitor/Tracing/Local.hs +36/−0
- src/Monitor/Tracing/Zipkin.hs +23/−19
- test/Spec.hs +5/−17
- tracing.cabal +2/−1
README.md view
@@ -13,9 +13,9 @@ -- A traced action with its root span and two children. run :: MonadTrace m => m ()-run = rootSpan (sampledEvery 10) do- childSpan "part-a" runA- childSpan "part-b" runB+run = rootSpan alwaysSampled "root" $ do+ childSpan "child-a" runA+ childSpan "child-b" runB ``` To learn more, hop on over to
src/Control/Monad/Trace.hs view
@@ -4,13 +4,23 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance. --- | This module is useful for tracing backend implementors. If you are only interested in adding--- tracing to an application, start at "Monitor.Tracing".+-- | This module is useful mostly for tracing backend implementors. If you are only interested in+-- adding tracing to an application, start at "Monitor.Tracing". module Control.Monad.Trace (- TraceT, runTraceT,- Tracer(..),- Tags, Logs, Interval(..),- newTracer+ -- * Tracers+ Tracer, newTracer,+ runTraceT, TraceT,++ -- * Collected data+ -- | Tracers currently expose two pieces of data: completed spans and pending span count. Note+ -- that only sampled spans are eligible: spans which are 'Control.Monad.Trace.Class.neverSampled'+ -- appear in neither.++ -- ** Completed spans+ spanSamples, Sample(..), Tags, Logs,++ -- ** Pending spans+ pendingSpanCount, ) where import Prelude hiding (span)@@ -19,8 +29,6 @@ import Control.Monad.Trace.Internal import Control.Applicative ((<|>))-import Control.Concurrent.STM (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan)-import Control.Exception (finally) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT(..), ask, asks, local, runReaderT) import Control.Monad.Reader.Class (MonadReader)@@ -32,33 +40,58 @@ 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)+import UnliftIO (MonadUnliftIO, UnliftIO(..), askUnliftIO, withUnliftIO)+import UnliftIO.Exception (finally)+import UnliftIO.STM (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar) -- | A collection of span tags. type Tags = Map Key JSON.Value --- | A collection of span logs, sorted in chronological order.+-- | A collection of span logs. type Logs = [(POSIXTime, Key, JSON.Value)] --- | Timing information about a span.-data Interval = Interval- { intervalStart :: !POSIXTime- , intervalDuration :: !NominalDiffTime+-- | A sampled span, and its associated metadata.+data Sample = Sample+ { sampleSpan :: !Span+ -- ^ The sampled span.+ , sampleTags :: !Tags+ -- ^ Tags collected during this span.+ , sampleLogs :: !Logs+ -- ^ Logs collected during this span, sorted in chronological order.+ , sampleStart :: !POSIXTime+ -- ^ The time the span started at.+ , sampleDuration :: !NominalDiffTime+ -- ^ The span's duration. } --- | A tracer collects spans emitted inside 'TraceT'.+-- | A tracer is a producer of spans.+--+-- More specifically, a tracer:+--+-- * runs 'MonadTrace' actions via 'runTraceT',+-- * transparently collects their generated spans,+-- * and outputs them to a channel (available via 'spanSamples').+--+-- These samples can then be consumed independently, decoupling downstream span processing from+-- their production. data Tracer = Tracer- { tracerChannel :: TChan (Span, Tags, Logs, Interval)- -- ^ Channel spans get written to when they complete.+ { tracerChannel :: TChan Sample , tracerPendingCount :: TVar Int- -- ^ The number of spans currently in flight (started but not yet completed). } -- | Creates a new 'Tracer'. newTracer :: MonadIO m => m Tracer newTracer = liftIO $ Tracer <$> newTChanIO <*> newTVarIO 0 +-- | Returns the number of spans currently in flight (started but not yet completed).+pendingSpanCount :: Tracer -> TVar Int+pendingSpanCount = tracerPendingCount++-- | Returns all newly completed spans' samples. The samples become available in the same order they+-- are completed.+spanSamples :: Tracer -> TChan Sample+spanSamples = tracerChannel+ data Scope = Scope { scopeTracer :: !Tracer , scopeSpan :: !(Maybe Span)@@ -66,7 +99,7 @@ , scopeLogs :: !(Maybe (TVar Logs)) } --- | Asynchronous trace collection monad.+-- | A span generation monad. newtype TraceT m a = TraceT { traceTReader :: ReaderT Scope m a } deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) @@ -81,53 +114,63 @@ 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- logsTV <- liftIO $ newTVarIO []+ sampling <- case builderSamplingPolicy bldr of+ Just policy -> liftIO policy+ Nothing -> pure $ fromMaybe Never (spanSamplingDecision <$> mbParentSpn) let baggages = fromMaybe Map.empty $ contextBaggages <$> mbParentCtx ctx = Context traceID spanID (builderBaggages bldr `Map.union` baggages)- spn = Span (builderName bldr) ctx (builderReferences bldr) isSampled isDebug+ spn = Span (builderName bldr) ctx (builderReferences bldr) sampling tracer = scopeTracer parentScope- childScope = Scope tracer (Just spn) (Just tagsTV) (Just logsTV)- withRunInIO $ \run -> do- start <- getPOSIXTime- atomically $ modifyTVar' (tracerPendingCount tracer) (+1)- run (local (const childScope) reader) `finally` do- end <- getPOSIXTime- atomically $ do- modifyTVar' (tracerPendingCount tracer) (\n -> n - 1)- tags <- readTVar tagsTV- logs <- sortOn (\(t, k, _) -> (t, k)) <$> readTVar logsTV- writeTChan (tracerChannel tracer) (spn, tags, logs, Interval start (end - start))+ if spanIsSampled spn+ then do+ tagsTV <- newTVarIO $ builderTags bldr+ logsTV <- newTVarIO []+ startTV <- newTVarIO Nothing -- To detect whether an exception happened.+ let+ childScope = Scope tracer (Just spn) (Just tagsTV) (Just logsTV)+ run = do+ start <- liftIO $ getPOSIXTime+ atomically $ do+ writeTVar startTV (Just start)+ modifyTVar' (tracerPendingCount tracer) (+1)+ local (const childScope) reader+ cleanup = do+ end <- liftIO $ getPOSIXTime+ atomically $ readTVar startTV >>= \case+ Nothing -> pure () -- The action was interrupted before the span was pending.+ Just start -> do+ modifyTVar' (tracerPendingCount tracer) (\n -> n - 1)+ tags <- readTVar tagsTV+ logs <- sortOn (\(t, k, _) -> (t, k)) <$> readTVar logsTV+ writeTChan (tracerChannel tracer) (Sample spn tags logs start (end - start))+ run `finally` cleanup+ else local (const $ Scope tracer (Just spn) Nothing Nothing) reader activeSpan = TraceT $ asks scopeSpan addSpanEntry key (TagValue val) = TraceT $ asks scopeTags >>= \case Nothing -> pure ()- Just tv -> liftIO $ atomically $ modifyTVar' tv $ Map.insert key val+ Just tv -> atomically $ modifyTVar' tv $ Map.insert key val addSpanEntry key (LogValue val maybeTime) = TraceT $ asks scopeLogs >>= \case Nothing -> pure () Just tv -> do time <- case maybeTime of Nothing -> liftIO getPOSIXTime Just time' -> pure time'- liftIO $ atomically $ modifyTVar' tv ((time, key, val) :)+ atomically $ modifyTVar' tv ((time, key, val) :) instance MonadUnliftIO m => MonadUnliftIO (TraceT m) where askUnliftIO = TraceT $ withUnliftIO $ \u -> pure (UnliftIO (unliftIO u . traceTReader )) --- | Trace an action.+-- | Trace an action, sampling its generated spans. This method is thread-safe and can be used to+-- trace multiple actions concurrently.+--+-- Unless you are implementing a custom span publication backend, you should not need to call this+-- method explicitly. Instead, prefer to use the backend's functionality directly (e.g.+-- 'Monitor.Tracing.Zipkin.run' for Zipkin). To ease debugging in certain cases,+-- 'Monitor.Tracing.Local.collectSpanSamples' is also available. runTraceT :: TraceT m a -> Tracer -> m a runTraceT (TraceT reader) tracer = runReaderT reader (Scope tracer Nothing Nothing Nothing)
src/Control/Monad/Trace/Class.hs view
@@ -6,7 +6,8 @@ -- | This module exposes the generic 'MonadTrace' class. module Control.Monad.Trace.Class ( -- * Types- Span(..), Context(..),+ Span(..), spanIsSampled, spanIsDebug,+ Context(..), TraceID(..), decodeTraceID, encodeTraceID, SpanID(..), decodeSpanID, encodeSpanID, Reference(..),@@ -18,7 +19,8 @@ -- ** Structured traces rootSpan, rootSpanWith, childSpan, childSpanWith, -- ** Sampling- Sampling, alwaysSampled, neverSampled, sampledEvery, sampledWhen, debugEnabled,+ SamplingDecision(..),+ SamplingPolicy, alwaysSampled, neverSampled, sampledWithProbability, sampledWhen, debugEnabled, -- * Annotating traces -- | Note that not all annotation types are supported by all backends. For example Zipkin only@@ -50,6 +52,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock.POSIX (POSIXTime)+import System.Random (randomRIO) -- | A monad capable of generating and modifying trace spans. --@@ -124,10 +127,10 @@ -- ^ Initial set of tags. , builderBaggages :: !(Map Key ByteString) -- ^ Span context baggages.- , builderSampling :: !(Maybe Sampling)+ , builderSamplingPolicy :: !(Maybe SamplingPolicy) -- ^ 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@@ -136,37 +139,43 @@ instance IsString Builder where fromString = builder . T.pack --- | Returns a 'Sampling' which always samples.-alwaysSampled :: Sampling-alwaysSampled = Always+-- | An action to determine how a span should be sampled.+type SamplingPolicy = IO SamplingDecision --- | Returns a 'Sampling' which never samples.-neverSampled :: Sampling-neverSampled = Never+-- | Returns a 'SamplingPolicy' which always samples.+alwaysSampled :: SamplingPolicy+alwaysSampled = pure Always --- | Returns a debug 'Sampling'. Debug spans are always sampled.-debugEnabled :: Sampling-debugEnabled = Debug+-- | Returns a 'SamplingPolicy' which never samples.+neverSampled :: SamplingPolicy+neverSampled = pure Never --- | Returns a 'Sampling' which randomly samples one in every @n@ spans.-sampledEvery :: Int -> Sampling-sampledEvery n = WithProbability $ 1 / fromIntegral n+-- | Returns a debug 'SamplingPolicy'. Debug spans are always sampled.+debugEnabled :: SamplingPolicy+debugEnabled = pure Debug --- | Returns a 'Sampling' which samples a span iff the input is 'True'. It is equivalent to:+-- | Returns a 'SamplingPolicy' which samples a span iff the input is 'True'. It is equivalent to: -- -- > sampledWhen b = if b then alwaysSampled else neverSampled-sampledWhen :: Bool -> Sampling-sampledWhen b = if b then Always else Never+sampledWhen :: Bool -> SamplingPolicy+sampledWhen b = pure $ if b then Always else Never +-- | Returns a 'SamplingPolicy' which randomly samples spans.+sampledWithProbability :: Double -> SamplingPolicy+sampledWithProbability r = randomRIO (0, 1) >>= sampledWhen . (< r)+ -- 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 }+rootSpanWith :: MonadTrace m => (Builder -> Builder) -> SamplingPolicy -> Name -> m a -> m a+rootSpanWith f policy name = trace $ (f $ builder name) { builderSamplingPolicy = Just policy } --- | Starts a new trace.-rootSpan :: MonadTrace m => Sampling -> Name -> m a -> m a+-- | Starts a new trace. For performance reasons, it is possible to customize how frequently tracing+-- information is collected. This allows fine-grain control on the overhead induced by tracing. For+-- example, you might only want to sample 1% of a very actively used call-path with+-- @sampledWithProbability 0.01@.+rootSpan :: MonadTrace m => SamplingPolicy -> Name -> m a -> m a rootSpan = rootSpanWith id -- | Extends a trace, same as 'childSpan' but also customizing the builder.
src/Control/Monad/Trace/Internal.hs view
@@ -6,7 +6,7 @@ Context(..), Name, Span(..),- Sampling(..),+ SamplingDecision(..), spanIsSampled, spanIsDebug, Reference(..), Key, Value(..) ) where@@ -79,8 +79,7 @@ randomSpanID = SpanID <$> randomID 8 -- | A fully qualified span identifier, containing both the ID of the trace the span belongs to and--- the span's ID. Span contexts can be exported (resp. imported) via their 'JSON.toJSON' (resp.--- 'JSON.fromJSON') instance.+-- the span's ID. data Context = Context { contextTraceID :: !TraceID , contextSpanID :: !SpanID@@ -110,17 +109,23 @@ { spanName :: !Name , spanContext :: !Context , spanReferences :: !(Set Reference)- , spanIsSampled :: !Bool- , spanIsDebug :: !Bool+ , spanSamplingDecision :: !SamplingDecision } --- | A trace sampling strategy.-data Sampling+-- | A span's sampling decision.+data SamplingDecision = Always | Never | Debug- | WithProbability Double- deriving (Eq, Show)+ deriving (Eq, Ord, Enum, Show)++-- | Returns whether the span is sampled.+spanIsSampled :: Span -> Bool+spanIsSampled spn = spanSamplingDecision spn /= Never++-- | Returns whether the span has debug enabled.+spanIsDebug :: Span -> Bool+spanIsDebug spn = spanSamplingDecision spn == Debug randomID :: Int -> IO ByteString randomID len = BS.pack <$> replicateM len randomIO
src/Monitor/Tracing.hs view
@@ -36,17 +36,19 @@ -- > main :: IO () -- > main = ZPK.with ZPK.defaultSettings $ ZPK.run printTasks - -- * Generic trace creation+ -- * Trace creation MonadTrace,- -- ** Controlling the sampling rate- Sampling, alwaysSampled, neverSampled, sampledEvery, sampledWhen, debugEnabled,- -- ** Building hierarchical traces++ -- ** Starting a new trace -- | 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 lineage information is -- automatically propagated.- rootSpan, childSpan,+ rootSpan, alwaysSampled, neverSampled, sampledWhen, sampledWithProbability, debugEnabled,++ -- ** Extending a trace+ childSpan, -- * Backends -- | As a convenience, the top-level type for each backend is exported here.
+ src/Monitor/Tracing/Local.hs view
@@ -0,0 +1,36 @@+-- | This module provides convenience functionality to debug traces locally. For production use,+-- prefer alternatives, e.g. "Monitor.Tracing.Zipkin".+module Monitor.Tracing.Local (+ collectSpanSamples+) where++import Control.Concurrent.STM (atomically, readTVar, readTChan, tryReadTChan)+import Control.Monad.Fix (fix)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trace+import Data.IORef (modifyIORef', newIORef, readIORef)+import UnliftIO (MonadUnliftIO)++-- | Runs a 'TraceT' action, returning any collected samples alongside its output. The samples are+-- sorted chronologically by completion time (e.g. the head is the first span to complete).+--+-- Spans which start before the action returns are guaranteed to be collected, even if they complete+-- after (in this case collection will block until their completion). More precisely,+-- 'collectSamples' will return the first time there are no pending spans after the action is done.+collectSpanSamples :: MonadUnliftIO m => TraceT m a -> m (a, [Sample])+collectSpanSamples actn = do+ tracer <- newTracer+ rv <- runTraceT actn tracer+ ref <- liftIO $ newIORef []+ let+ addSample spl = liftIO $ modifyIORef' ref (spl:)+ samplesTC = spanSamples tracer+ pendingTV = pendingSpanCount tracer+ liftIO $ fix $ \loop -> do+ (mbSample, pending) <- atomically $ (,) <$> tryReadTChan samplesTC <*> readTVar pendingTV+ case mbSample of+ Just spl -> addSample spl >> loop+ Nothing | pending > 0 -> liftIO (atomically $ readTChan samplesTC) >>= addSample >> loop+ _ -> pure ()+ spls <- reverse <$> liftIO (readIORef ref)+ pure (rv, spls)
src/Monitor/Tracing/Zipkin.hs view
@@ -9,10 +9,9 @@ module Monitor.Tracing.Zipkin ( -- * Configuration -- ** General settings- Settings, defaultSettings, settingsHostname, settingsPort, settingsManager, settingsEndpoint,- settingsPublishPeriod,+ Settings(..), defaultSettings, -- ** Endpoint- Endpoint, defaultEndpoint, endpointService, endpointPort, endpointIPv4, endpointIPv6,+ Endpoint(..), defaultEndpoint, -- * Publishing traces Zipkin,@@ -20,7 +19,7 @@ -- * Cross-process spans -- ** Communication- B3, b3ToHeaders, b3FromHeaders, b3ToHeaderValue, b3FromHeaderValue,+ B3(..), b3ToHeaders, b3FromHeaders, b3ToHeaderValue, b3FromHeaderValue, -- ** Span generation clientSpan, serverSpan, producerSpan, consumerSpan, @@ -66,9 +65,7 @@ import UnliftIO (MonadUnliftIO) import UnliftIO.Exception (finally) --- | 'Zipkin' creation settings. Note that its constructor is not exposed to allow backwards--- compatible evolution; 'Settings' should instead be created either via 'defaultSettings' or its--- 'IsString' instance.+-- | 'Zipkin' creation settings. data Settings = Settings { settingsHostname :: !(Maybe HostName) -- ^ The Zipkin server's hostname, defaults to @localhost@ if unset.@@ -94,6 +91,10 @@ fromString s = defaultSettings { settingsHostname = Just s } -- | A Zipkin trace publisher.+--+-- All publisher functionality is thread-safe. In particular it is safe to 'publish' concurrently+-- with 'run', and/or 'run' multiple actions concurrently. Note also that all sampled spans are+-- retained in memory until they are published. data Zipkin = Zipkin { zipkinManager :: !Manager , zipkinRequest :: !Request@@ -104,11 +105,9 @@ flushSpans :: Maybe Endpoint -> Tracer -> Request -> Manager -> IO () flushSpans ept tracer req mgr = do ref <- newIORef []- fix $ \loop -> atomically (tryReadTChan $ tracerChannel tracer) >>= \case+ fix $ \loop -> atomically (tryReadTChan $ spanSamples tracer) >>= \case Nothing -> pure ()- Just (spn, tags, logs, itv) -> do- when (spanIsSampled spn) $ modifyIORef ref (ZipkinSpan ept spn tags logs itv:)- loop+ Just sample -> modifyIORef ref (ZipkinSpan ept sample:) >> loop spns <- readIORef ref when (not $ null spns) $ do let req' = req { HTTP.requestBody = HTTP.RequestBodyLBS $ JSON.encode spns }@@ -138,7 +137,7 @@ 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.+-- | Flushes all complete spans to the Zipkin server. publish :: MonadIO m => Zipkin -> m () publish z = liftIO $ flushSpans (zipkinEndpoint z) (zipkinTracer z) (zipkinRequest z) (zipkinManager z)@@ -188,10 +187,15 @@ -- | Exportable trace information, used for cross-process traces. data B3 = B3 { b3TraceID :: !TraceID+ -- ^ The span's trace ID. , b3SpanID :: !SpanID+ -- ^ The span's ID. , b3IsSampled :: !Bool+ -- ^ Whether the span was sampled. , b3IsDebug :: !Bool+ -- ^ Whether the span has debug enabled (which implies that the span is sampled). , b3ParentSpanID :: !(Maybe SpanID)+ -- ^ The span's parent's ID, or 'Nothing' for root spans. } deriving (Eq, Ord, Show) traceIDHeader, spanIDHeader, parentSpanIDHeader, sampledHeader, debugHeader :: CI ByteString@@ -284,13 +288,13 @@ importB3 :: B3 -> Endo Builder importB3 b3 = let- sampling = if b3IsDebug b3+ policy = if b3IsDebug b3 then debugEnabled else sampledWhen $ b3IsSampled b3 in Endo $ \bldr -> bldr { builderTraceID = Just (b3TraceID b3) , builderSpanID = Just (b3SpanID b3)- , builderSampling = Just sampling }+ , builderSamplingPolicy = Just policy } publicKeyPrefix :: Text publicKeyPrefix = "Z."@@ -335,7 +339,7 @@ in trace bldr actn -- | Generates a child span with @SERVER@ kind. The client's 'B3' should be provided as input,--- for example parsed using 'b3FromRequestHeaders'.+-- for example parsed using 'b3FromHeaders'. serverSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a serverSpan = incomingSpan "SERVER" @@ -384,7 +388,7 @@ -- Internal type used to encode spans in the <https://zipkin.apache.org/zipkin-api/#/ format> -- expected by Zipkin.-data ZipkinSpan = ZipkinSpan !(Maybe Endpoint) !Span !Tags !Logs !Interval+data ZipkinSpan = ZipkinSpan !(Maybe Endpoint) !Sample publicTags :: Tags -> Map Text JSON.Value publicTags = Map.fromList . catMaybes . fmap go . Map.assocs where@@ -393,15 +397,15 @@ Just k' -> Just (k', v) instance JSON.ToJSON ZipkinSpan where- toJSON (ZipkinSpan mbEpt spn tags logs itv) =+ toJSON (ZipkinSpan mbEpt (Sample spn tags logs start duration)) = let ctx = spanContext spn requiredKVs = [ "traceId" JSON..= contextTraceID ctx , "name" JSON..= spanName spn , "id" JSON..= contextSpanID ctx- , "timestamp" JSON..= microSeconds @Int64 (intervalStart itv)- , "duration" JSON..= microSeconds @Int64 (intervalDuration itv)+ , "timestamp" JSON..= microSeconds @Int64 start+ , "duration" JSON..= microSeconds @Int64 duration , "debug" JSON..= spanIsDebug spn , "tags" JSON..= (publicTags tags <> (JSON.toJSON . T.decodeUtf8 <$> contextBaggages ctx)) , "annotations" JSON..= fmap (\(t, _, v) -> ZipkinAnnotation t v) logs ]
test/Spec.hs view
@@ -6,15 +6,11 @@ import Control.Monad.Trace import Control.Monad.Trace.Class import Monitor.Tracing+import Monitor.Tracing.Local (collectSpanSamples) import qualified Monitor.Tracing.Zipkin as ZPK -import Control.Concurrent-import Control.Concurrent.STM (atomically, tryReadTChan)-import Control.Monad.Fix (fix)-import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (MonadReader, Reader, ReaderT, ask, runReader, runReaderT) import Control.Monad.State.Strict (MonadState, StateT, evalStateT, get)-import Data.IORef import qualified Data.Map.Strict as Map import Data.Text (Text) import Test.Hspec@@ -22,14 +18,7 @@ import UnliftIO (MonadUnliftIO) collectSpans :: MonadUnliftIO m => TraceT m () -> m [Span]-collectSpans actn = do- tracer <- newTracer- runTraceT actn tracer- ref <- liftIO $ newIORef []- liftIO $ fix $ \loop -> atomically (tryReadTChan $ tracerChannel tracer) >>= \case- Nothing -> pure ()- Just (spn, _, _, _) -> modifyIORef ref (spn:) >> loop- reverse <$> liftIO (readIORef ref)+collectSpans actn = fmap sampleSpan . snd <$> collectSpanSamples actn main :: IO () main = hspec $ do@@ -48,12 +37,11 @@ spans <- collectSpans @IO (pure ()) fmap spanName spans `shouldBe` [] it "should collect a single span when no children are created" $ do- spans <- collectSpans @IO (trace "t0" $ pure ())- fmap spanName spans `shouldBe` ["t0"]+ spans <- collectSpans @IO (trace "t" { builderSamplingPolicy = Just alwaysSampled } $ pure ())+ fmap spanName spans `shouldBe` ["t"] it "should be able to stack on top of a ReaderT" $ do- spans <- (collectSpans @IO) $ trace "c2" $ pure () let- actn = trace "t" $ do+ actn = trace "t" { builderSamplingPolicy = Just alwaysSampled } $ do name <- ask trace (builder name) $ pure () spans <- runReaderT (collectSpans @(ReaderT Text IO) actn) "foo"
tracing.cabal view
@@ -1,5 +1,5 @@ name: tracing-version: 0.0.2.4+version: 0.0.3.0 synopsis: Distributed tracing description: An OpenTracing-compliant, simple, and extensible distributed tracing library. homepage: https://github.com/mtth/tracing@@ -18,6 +18,7 @@ exposed-modules: Control.Monad.Trace , Control.Monad.Trace.Class , Monitor.Tracing+ , Monitor.Tracing.Local , Monitor.Tracing.Zipkin other-modules: Control.Monad.Trace.Internal build-depends: aeson >= 1.4