diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 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 @@ -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) 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 @@ -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. 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 @@ -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 diff --git a/src/Monitor/Tracing.hs b/src/Monitor/Tracing.hs --- a/src/Monitor/Tracing.hs +++ b/src/Monitor/Tracing.hs @@ -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. diff --git a/src/Monitor/Tracing/Local.hs b/src/Monitor/Tracing/Local.hs new file mode 100644 --- /dev/null +++ b/src/Monitor/Tracing/Local.hs @@ -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) 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 @@ -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 -- 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 ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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" diff --git a/tracing.cabal b/tracing.cabal --- a/tracing.cabal +++ b/tracing.cabal @@ -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