summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormtth <>2019-06-11 00:30:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-06-11 00:30:00 (GMT)
commite6f310521a9c7bf62beea92bd8c2025badaacaac (patch)
tree5b26414ccf1571e95d963ac4300912a583b80135
parent94629d7315c969fe3dea9126e60bc05e0ccd817f (diff)
version 0.0.3.00.0.3.0
-rw-r--r--README.md6
-rw-r--r--src/Control/Monad/Trace.hs137
-rw-r--r--src/Control/Monad/Trace/Class.hs57
-rw-r--r--src/Control/Monad/Trace/Internal.hs23
-rw-r--r--src/Monitor/Tracing.hs12
-rw-r--r--src/Monitor/Tracing/Local.hs36
-rw-r--r--src/Monitor/Tracing/Zipkin.hs42
-rw-r--r--test/Spec.hs22
-rw-r--r--tracing.cabal3
9 files changed, 213 insertions, 125 deletions
diff --git a/README.md b/README.md
index bf911de..e8daf4d 100644
--- a/README.md
+++ b/README.md
@@ -13,9 +13,9 @@ import Monitor.Tracing
-- 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
index 686be81..1867d52 100644
--- 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.Class
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 qualified Data.Map.Strict as Map
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 @@ data Scope = Scope
, 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 @@ instance MonadUnliftIO m => MonadTrace (TraceT m) where
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
index ffae367..5318163 100644
--- 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 @@ module Control.Monad.Trace.Class (
-- ** 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.String (IsString(..))
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 @@ data Builder = Builder
-- ^ 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 @@ builder name = Builder name Nothing Nothing Set.empty Map.empty Map.empty Nothin
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 }
-
--- | Starts a new trace.
-rootSpan :: MonadTrace m => Sampling -> Name -> m a -> m a
+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. 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
index 1dc4ad9..d5f3a1c 100644
--- a/src/Control/Monad/Trace/Internal.hs
+++ b/src/Control/Monad/Trace/Internal.hs
@@ -6,7 +6,7 @@ module Control.Monad.Trace.Internal (
Context(..),
Name,
Span(..),
- Sampling(..),
+ SamplingDecision(..), spanIsSampled, spanIsDebug,
Reference(..),
Key, Value(..)
) where
@@ -79,8 +79,7 @@ randomSpanID :: IO SpanID
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 @@ data Span = Span
{ 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
index 6693b01..5db6d9e 100644
--- a/src/Monitor/Tracing.hs
+++ b/src/Monitor/Tracing.hs
@@ -36,17 +36,19 @@ module Monitor.Tracing (
-- > 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
index 0000000..c0f2546
--- /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
index f702e3b..1fab6a4 100644
--- 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 @@ module Monitor.Tracing.Zipkin (
-- * 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 Network.Socket (HostName, PortNumber)
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 @@ instance IsString Settings where
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 @@ data Zipkin = Zipkin
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 @@ new (Settings mbHostname mbPort mbEpt mbMgr mbPrd) = liftIO $ do
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 @@ annotateAt time val = addSpanEntry "" (logValueAt time val)
-- | 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 @@ insertTag key val =
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 @@ incomingSpan kind mbEpt b3 actn =
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 @@ instance JSON.ToJSON ZipkinAnnotation where
-- 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 @@ publicTags = Map.fromList . catMaybes . fmap go . Map.assocs where
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
index adcdf66..d12856b 100644
--- 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 Test.Hspec.QuickCheck
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 @@ main = hspec $ do
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
index c1a9574..762e024 100644
--- 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 @@ library
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