tracing-control (empty) → 0.0.6
raw patch · 11 files changed
+1317/−0 lines, 11 filesdep +aesondep +basedep +base16-bytestringsetup-changed
Dependencies added: aeson, base, base16-bytestring, bytestring, case-insensitive, containers, hspec, http-client, lifted-base, monad-control, mtl, network, random, stm, stm-lifted, text, time, tracing-control, transformers, transformers-base
Files
- LICENSE +30/−0
- README.md +25/−0
- Setup.hs +2/−0
- src/Control/Monad/Trace.hs +195/−0
- src/Control/Monad/Trace/Class.hs +222/−0
- src/Control/Monad/Trace/Internal.hs +139/−0
- src/Monitor/Tracing.hs +59/−0
- src/Monitor/Tracing/Local.hs +43/−0
- src/Monitor/Tracing/Zipkin.hs +449/−0
- test/Spec.hs +77/−0
- tracing-control.cabal +76/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Matthieu Monsch (c) 2019-2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Matthieu Monsch nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,25 @@+# Tracing [](https://hackage.haskell.org/package/tracing-control)++**Important note**: this is a fork of the original [tracing](https://github.com/mtth/tracing) library in which `unliftio` has been replaced by `monad-control`.++An [OpenTracing](https://opentracing.io/)-compliant, simple, and extensible+distributed tracing library.+++ _Simple:_ add a single `MonadTrace` constraint to start tracing, without+ making your code harder to test!++ _Extensible:_ use the built-in [Zipkin](http://zipkin.io) backend or hook in+ your own trace publication logic.++```haskell+import Monitor.Tracing++-- A traced action with its root span and two children.+run :: MonadTrace m => m ()+run = rootSpan alwaysSampled "parent" $ do+ childSpan "child-a" runA+ childSpan "child-b" runB+```++To learn more, hop on over to+[`Monitor.Tracing`](https://hackage.haskell.org/package/tracing/docs/Monitor-Tracing.html),+or take a look at examples in the `examples/` folder.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Control/Monad/Trace.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} -- For the MonadBaseControl instance.+{-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance.++-- | 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 (+ -- * 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)++import Control.Monad.Trace.Class+import Control.Monad.Trace.Internal++import Control.Applicative ((<|>))+import Control.Concurrent.STM.Lifted (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar)+import Control.Exception.Lifted (finally)+import Control.Monad.Base (MonadBase, liftBase)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (ReaderT(ReaderT), ask, asks, local, runReaderT)+import Control.Monad.Reader.Class (MonadReader)+import Control.Monad.Error.Class (MonadError)+import Control.Monad.State.Class (MonadState)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Trans.Control (MonadBaseControl(..), RunInBase)+import Control.Monad.Writer.Class (MonadWriter)+import qualified Data.Aeson as JSON+import Data.Coerce+import Data.Foldable (for_)+import Data.List (sortOn)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Time.Clock (NominalDiffTime)+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)++-- | A collection of span tags.+type Tags = Map Key JSON.Value++-- | A collection of span logs.+type Logs = [(POSIXTime, Key, JSON.Value)]++-- | 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 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 Sample+ , tracerPendingCount :: TVar Int+ }++-- | 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)+ , scopeTags :: !(Maybe (TVar Tags))+ , scopeLogs :: !(Maybe (TVar Logs))+ }++-- | A span generation monad.+newtype TraceT m a = TraceT { traceTReader :: ReaderT Scope m a }+ deriving ( Functor, Applicative, Monad, MonadTrans+ , MonadWriter w, MonadState s, MonadError e+ , MonadIO, MonadBase b )++instance MonadReader r m => MonadReader r (TraceT m) where+ ask = lift ask+ local f (TraceT (ReaderT g)) = TraceT $ ReaderT $ \r -> local f $ g r++-- Cannot be derived in GHC 8.0 due to type family.+instance MonadBaseControl b m => MonadBaseControl b (TraceT m) where+ type StM (TraceT m) a = StM (ReaderT Scope m) a+ liftBaseWith :: forall a. (RunInBase (TraceT m) b -> b a) -> TraceT m a+ liftBaseWith+ = coerce @((RunInBase (ReaderT Scope m) b -> b a) -> ReaderT Scope m a)+ liftBaseWith+ restoreM :: forall a. StM (TraceT m) a -> TraceT m a+ restoreM+ = coerce @(StM (ReaderT Scope m) a -> ReaderT Scope m a)+ restoreM++instance (MonadIO m, MonadBaseControl IO m) => MonadTrace (TraceT m) where+ trace bldr (TraceT reader) = TraceT $ do+ parentScope <- ask+ let+ mbParentSpn = scopeSpan parentScope+ mbParentCtx = spanContext <$> mbParentSpn+ mbTraceID = contextTraceID <$> mbParentCtx+ spanID <- maybe (liftBase randomSpanID) pure $ builderSpanID bldr+ traceID <- maybe (liftBase randomTraceID) pure $ builderTraceID bldr <|> mbTraceID+ 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) sampling+ tracer = scopeTracer parentScope+ if spanIsSampled spn+ then do+ tagsTV <- newTVarIO $ builderTags bldr+ logsTV <- newTVarIO []+ startTV <- newTVarIO Nothing -- To detect whether an exception happened during span setup.+ let+ run = do+ start <- liftIO $ getPOSIXTime+ atomically $ do+ writeTVar startTV (Just start)+ modifyTVar' (tracerPendingCount tracer) (+1)+ local (const $ Scope tracer (Just spn) (Just tagsTV) (Just logsTV)) 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 $ do+ mbTV <- asks scopeTags+ for_ mbTV $ \tv -> atomically $ modifyTVar' tv $ Map.insert key val+ addSpanEntry key (LogValue val mbTime) = TraceT $ do+ mbTV <- asks scopeLogs+ for_ mbTV $ \tv -> do+ time <- maybe (liftIO getPOSIXTime) pure mbTime+ atomically $ modifyTVar' tv ((time, key, val) :)++-- | 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
@@ -0,0 +1,222 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module exposes the generic 'MonadTrace' class.+module Control.Monad.Trace.Class (+ -- * Types+ Span(..), spanIsSampled, spanIsDebug,+ Context(..),+ TraceID(..), decodeTraceID, encodeTraceID,+ SpanID(..), decodeSpanID, encodeSpanID,+ Reference(..),++ -- * Generating traces+ -- ** Individual spans+ MonadTrace(..),+ Builder(..), Name, builder,+ -- ** Structured traces+ rootSpan, rootSpanWith, childSpan, childSpanWith,+ -- ** Sampling+ SamplingDecision(..),+ SamplingPolicy, alwaysSampled, neverSampled, sampledWithProbability, sampledWhen, debugEnabled,++ -- * 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).+ Key, Value, tagDoubleValue, tagInt64Value, tagTextValue, logValue, logValueAt+) where++import Control.Monad.Trace.Internal++import Control.Monad.Except (ExceptT(..))+import Control.Monad.Identity (Identity(..))+import Control.Monad.Reader (ReaderT(..))+import qualified Control.Monad.RWS.Lazy as RWS.Lazy+import qualified Control.Monad.RWS.Strict as RWS.Strict+import qualified Control.Monad.State.Lazy as State.Lazy+import qualified Control.Monad.State.Strict as State.Strict+import Control.Monad.Trans.Class (MonadTrans, lift)+import qualified Control.Monad.Writer.Lazy as Writer.Lazy+import qualified Control.Monad.Writer.Strict as Writer.Strict+import qualified Data.Aeson as JSON+import Data.ByteString (ByteString)+import Data.Int (Int64)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+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.+--+-- This package currently provides two instances of this class:+--+-- * 'Control.Monad.Trace.TraceT', which emits spans for each trace in 'IO' and is meant to be used+-- in production.+-- * 'Identity', where tracing is a no-op and allows testing traced functions without any overhead+-- or complex setup.+class Monad m => MonadTrace m where++ -- | Trace an action, wrapping it inside a new span. If the action isn't currently being traced,+ -- 'trace' should be a no-op. Otherwise, the new span should share the active span's trace ID,+ -- sampling decision, and baggages unless overridden by the input 'Builder'.+ trace :: Builder -> m a -> m a++ -- | Extracts the currently active span, or 'Nothing' if the action is not being traced.+ activeSpan :: m (Maybe Span)+ default activeSpan :: (MonadTrace n, MonadTrans t, m ~ t n) => m (Maybe Span)+ activeSpan = lift activeSpan++ -- | Adds information to the active span, if present.+ addSpanEntry :: Key -> Value -> m ()+ default addSpanEntry :: (MonadTrace n, MonadTrans t, m ~ t n) => Key -> Value -> m ()+ addSpanEntry key = lift . addSpanEntry key++instance MonadTrace m => MonadTrace (ExceptT e m) where+ trace name (ExceptT actn) = ExceptT $ trace name actn++instance MonadTrace m => MonadTrace (ReaderT r m) where+ trace name (ReaderT actn) = ReaderT $ \r -> trace name (actn r)++instance (MonadTrace m, Monoid w) => MonadTrace (RWS.Lazy.RWST r w s m) where+ trace name (RWS.Lazy.RWST actn) = RWS.Lazy.RWST $ \r s -> trace name (actn r s)++instance (MonadTrace m, Monoid w) => MonadTrace (RWS.Strict.RWST r w s m) where+ trace name (RWS.Strict.RWST actn) = RWS.Strict.RWST $ \r s -> trace name (actn r s)++instance MonadTrace m => MonadTrace (State.Lazy.StateT s m) where+ trace name (State.Lazy.StateT actn) = State.Lazy.StateT $ \s -> trace name (actn s)++instance MonadTrace m => MonadTrace (State.Strict.StateT s m) where+ trace name (State.Strict.StateT actn) = State.Strict.StateT $ \s -> trace name (actn s)++instance (MonadTrace m, Monoid w) => MonadTrace (Writer.Lazy.WriterT w m) where+ trace name (Writer.Lazy.WriterT actn) = Writer.Lazy.WriterT $ trace name actn++instance (MonadTrace m, Monoid w) => MonadTrace (Writer.Strict.WriterT w m) where+ trace name (Writer.Strict.WriterT actn) = Writer.Strict.WriterT $ trace name actn++instance MonadTrace Identity where+ trace _ = id+ activeSpan = pure Nothing+ addSpanEntry _ _ = pure ()++-- Creating traces++-- | A span builder.+--+-- '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+ -- ^ Name of the generated span.+ , builderTraceID :: !(Maybe TraceID)+ -- ^ The trace ID of the generated span. If unset, the active span's trace ID will be used if+ -- present, otherwise a new ID will be generated.+ , builderSpanID :: !(Maybe SpanID)+ -- ^ The ID of the generated span, otherwise the ID will be auto-generated.+ , builderReferences :: !(Set Reference)+ -- ^ Span references.+ , builderTags :: !(Map Key JSON.Value)+ -- ^ Initial set of tags.+ , builderBaggages :: !(Map Key ByteString)+ -- ^ Span context baggages.+ , 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.+ }++-- | 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 Nothing++instance IsString Builder where+ fromString = builder . T.pack++-- | An action to determine how a span should be sampled.+type SamplingPolicy = IO SamplingDecision++-- | Returns a 'SamplingPolicy' which always samples.+alwaysSampled :: SamplingPolicy+alwaysSampled = pure Always++-- | Returns a 'SamplingPolicy' which never samples.+neverSampled :: SamplingPolicy+neverSampled = pure Never++-- | Returns a debug 'SamplingPolicy'. Debug spans are always sampled.+debugEnabled :: SamplingPolicy+debugEnabled = pure Debug++-- | 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 -> 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) -> 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.+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: 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++-- Writing metadata++-- | Generates a tag value from a double.+tagDoubleValue :: Double -> Value+tagDoubleValue = TagValue . JSON.toJSON++-- | Generates a 64-bit integer tag value from any integer.+tagInt64Value :: Integral a => a -> Value+tagInt64Value = TagValue . (JSON.toJSON @Int64) . fromIntegral++-- | Generates a Unicode text tag value.+tagTextValue :: Text -> Value+tagTextValue = TagValue . JSON.toJSON++-- | Generates a log value with the time of writing as timestamp. Note that the value may be written+-- later than it is created. For more control on the timestamp, use 'logValueAt'.+logValue :: JSON.ToJSON a => a -> Value+logValue v = LogValue (JSON.toJSON v) Nothing++-- | Generates a log value with a custom time.+logValueAt :: JSON.ToJSON a => POSIXTime -> a -> Value+logValueAt t v = LogValue (JSON.toJSON v) (Just t)
+ src/Control/Monad/Trace/Internal.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings #-}++module Control.Monad.Trace.Internal (+ TraceID(..), encodeTraceID, decodeTraceID, randomTraceID,+ SpanID(..), encodeSpanID, decodeSpanID, randomSpanID,+ Context(..),+ Name,+ Span(..),+ SamplingDecision(..), spanIsSampled, spanIsDebug,+ Reference(..),+ Key, Value(..)+) where++import Control.Monad (replicateM)+import qualified Data.Aeson as JSON+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS.Char8+import qualified Data.ByteString.Base16 as Base16+import Data.Map.Strict (Map)+import Data.Set (Set)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Clock.POSIX (POSIXTime)+import System.Random (randomIO)++-- | The name of a span.+type Name = Text++-- | The type of annotations' keys.+--+-- Keys starting with double underscores are reserved and should not be used.+type Key = Text++-- | 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" $ maybe (fail "invalid hex-encoding") pure . decodeTraceID++instance JSON.ToJSON TraceID where+ toJSON = JSON.toJSON . encodeTraceID++-- | Generates a random trace ID.+randomTraceID :: IO TraceID+randomTraceID = TraceID <$> randomID 16++-- | 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" $ maybe (fail "invalid hex-encoding") pure . decodeSpanID++instance JSON.ToJSON SpanID where+ toJSON = JSON.toJSON . encodeSpanID++-- | Generates a random span ID.+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.+data Context = Context+ { contextTraceID :: !TraceID+ , contextSpanID :: !SpanID+ , contextBaggages :: !(Map Key ByteString)+ } deriving (Eq, Ord, Show)++-- | A relationship between spans.+--+-- There are currently two types of references, both of which model direct causal relationships+-- between a child and a parent. More background on references is available in the opentracing+-- specification: https://github.com/opentracing/specification/blob/master/specification.md.+data Reference+ = ChildOf !SpanID+ -- ^ 'ChildOf' references imply that the parent span depends on the child span in some capacity.+ -- Note that this reference type is only valid within a single trace.+ | FollowsFrom !Context+ -- ^ If the parent does not depend on the child, we use a 'FollowsFrom' reference.+ deriving (Eq, Ord, Show)++-- | Metadata attached to a span.+data Value+ = TagValue !JSON.Value+ | LogValue !JSON.Value !(Maybe POSIXTime)++-- | A part of a trace.+data Span = Span+ { spanName :: !Name+ , spanContext :: !Context+ , spanReferences :: !(Set Reference)+ , spanSamplingDecision :: !SamplingDecision+ }++-- | A span's sampling decision.+data SamplingDecision+ = Always+ | Never+ | Debug+ 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++hexDecode :: Text-> Maybe ByteString+hexDecode t = case Base16.decode $ BS.Char8.pack $ T.unpack t of+ (bs, trail) | BS.null trail -> Just bs+ _ -> Nothing++hexEncode :: ByteString -> Text+hexEncode = T.pack . BS.Char8.unpack . Base16.encode
+ src/Monitor/Tracing.hs view
@@ -0,0 +1,59 @@+-- | This module is where you should start if you are interested in adding tracing to an+-- application. It provides backend-agnostic utilities to generate traces. Trace publication and+-- other backend-specific features are available in the modules below @Monitor.Tracing@ (e.g.+-- "Monitor.Tracing.Zipkin"). The additional functionality exposed under @Control.Monad@ in this+-- package is useful if you wish to implement a new tracing backend.+module Monitor.Tracing (+ -- * Overview+ -- | Let's assume 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.+ --+ -- We can do so simply by wrapping them inside 'childSpan' calls and adding a 'MonadTrace'+ -- constraint:+ --+ -- > import Monitor.Tracing+ -- >+ -- > 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 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:+ --+ -- > printTasks :: (MonadIO m, MonadTrace m) => m ()+ -- > printTasks = rootSpan alwaysSampled "list-tasks" $ listTaskIDs >>= fetchTasks >>= print+ --+ -- Spans can then be published to various backends. For example, to run the above action and+ -- publish its spans using Zipkin:+ --+ -- > import qualified Monitor.Tracing.Zipkin as ZPK+ -- >+ -- > main :: IO ()+ -- > main = ZPK.with ZPK.defaultSettings $ ZPK.run printTasks++ -- * Trace creation+ MonadTrace,++ -- ** 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, alwaysSampled, neverSampled, sampledWhen, sampledWithProbability, debugEnabled,++ -- ** Extending a trace+ childSpan,++ -- * Backends+ -- | As a convenience, the top-level type for each backend is exported here.+ Zipkin+) where++import Control.Monad.Trace.Class+import Monitor.Tracing.Zipkin (Zipkin)
+ src/Monitor/Tracing/Local.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleContexts #-}+-- | 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 (MonadIO, liftIO)+import Control.Monad.Trace+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.IORef (modifyIORef', newIORef, readIORef)++-- | 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,+-- 'collectSpanSamples' will return the first time there are no pending spans after the action is+-- done. For example:+--+-- > collectSpanSamples $ rootSpan alwaysSampled "parent" $ do+-- > forkIO $ childSpan "child" $ threadDelay 2000000 -- Asynchronous 2 second child span.+-- > threadDelay 1000000 -- Returns after one second, but the child span will still be sampled.+collectSpanSamples :: (MonadIO m, MonadBaseControl IO 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
@@ -0,0 +1,449 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++-- | This module implements a <https://zipkin.apache.org/ Zipkin>-powered trace publisher. You will+-- almost certainly want to import it qualified.+--+-- Zipkin does not support all OpenTracing functionality. To guarantee that everything works as+-- expected, you should only use the functions defined in this module or exported by+-- "Monitor.Tracing".+module Monitor.Tracing.Zipkin (+ -- * Configuration+ -- ** General settings+ Settings(..), defaultSettings,+ -- ** Endpoint+ Endpoint(..), defaultEndpoint,++ -- * Publishing traces+ Zipkin,+ new, run, publish, with,++ -- * Cross-process spans+ -- ** Communication+ B3(..), b3ToHeaders, b3FromHeaders, b3ToHeaderValue, b3FromHeaderValue,+ -- ** Span generation+ clientSpan, clientSpanWith, serverSpan, serverSpanWith, producerSpanWith, consumerSpanWith,++ -- * Custom metadata+ -- ** Tags+ tag, addTag, addInheritedTag,+ -- ** Annotations+ -- | Annotations are similar to tags, but timestamped.+ annotate, annotateAt,+ -- ** Endpoints+ addEndpoint+) where++import Control.Monad.Trace+import Control.Monad.Trace.Class++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM (atomically, tryReadTChan)+import Control.Exception.Lifted (finally)+import Control.Monad (forever, guard, void, when)+import Control.Monad.Fix (fix)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Data.Aeson as JSON+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.CaseInsensitive (CI)+import Data.Time.Clock (NominalDiffTime)+import Data.Foldable (toList)+import Data.Int (Int64)+import Data.IORef (modifyIORef, newIORef, readIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, fromMaybe, listToMaybe, maybeToList)+import Data.Monoid (Endo(..))+#if !MIN_VERSION_base(4, 11, 0)+import Data.Semigroup ((<>))+#endif+import Data.Set (Set)+import Data.String (IsString(..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time.Clock.POSIX (POSIXTime)+import Network.HTTP.Client (Manager, Request)+import qualified Network.HTTP.Client as HTTP+import Network.Socket (HostName, PortNumber)++-- | 'Zipkin' creation settings.+data Settings = Settings+ { settingsHostname :: !(Maybe HostName)+ -- ^ The Zipkin server's hostname, defaults to @localhost@ if unset.+ , settingsPort :: !(Maybe PortNumber)+ -- ^ The port the Zipkin server is listening on, defaults to @9411@ if unset.+ , settingsEndpoint :: !(Maybe Endpoint)+ -- ^ Local endpoint included in all published spans.+ , settingsManager :: !(Maybe Manager)+ -- ^ An optional HTTP manager to use for publishing spans on the Zipkin server.+ , settingsPublishPeriod :: !(Maybe NominalDiffTime)+ -- ^ If set to a positive value, traces will be flushed in the background every such period.+ }++-- | Creates empty 'Settings'. You will typically use this (or the 'IsString' instance) as starting+-- point to only fill in the fields you care about:+--+-- > let settings = defaultSettings { settingsPort = Just 2222 }+defaultSettings :: Settings+defaultSettings = Settings Nothing Nothing Nothing Nothing Nothing++-- | Generates settings with the given string as hostname.+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+ , zipkinTracer :: !Tracer+ , zipkinEndpoint :: !(Maybe Endpoint)+ }++flushSpans :: Maybe Endpoint -> Tracer -> Request -> Manager -> IO ()+flushSpans ept tracer req mgr = do+ ref <- newIORef []+ fix $ \loop -> atomically (tryReadTChan $ spanSamples tracer) >>= \case+ Nothing -> pure ()+ 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 }+ void $ HTTP.httpLbs req' mgr++-- | Creates a 'Zipkin' publisher for the input 'Settings'.+new :: MonadIO m => Settings -> m Zipkin+new (Settings mbHostname mbPort mbEpt mbMgr mbPrd) = liftIO $ do+ mgr <- maybe (HTTP.newManager HTTP.defaultManagerSettings) pure mbMgr+ tracer <- newTracer+ let+ req = HTTP.defaultRequest+ { HTTP.method = "POST"+ , HTTP.host = BS.pack (fromMaybe "localhost" mbHostname)+ , HTTP.requestHeaders = [("Content-Type", "application/json")]+ , HTTP.path = "/api/v2/spans"+ , HTTP.port = maybe 9411 fromIntegral mbPort }+ void $ let prd = fromMaybe 0 mbPrd in if prd <= 0+ then pure Nothing+ else fmap Just $ forkIO $ forever $ do+ threadDelay (microSeconds prd)+ flushSpans mbEpt tracer req mgr -- Manager is thread-safe.+ pure $ Zipkin mgr req tracer mbEpt++-- | 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 :: TraceT m a -> Zipkin -> m a+run actn zipkin = runTraceT actn (zipkinTracer zipkin)++-- | 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)++-- | Convenience method to start a 'Zipkin', run an action, and publish all spans before returning.+with :: (MonadIO m, MonadBaseControl IO m)+ => Settings -> (Zipkin -> m a) -> m a+with settings f = do+ zipkin <- new settings+ f zipkin `finally` publish zipkin++-- | Adds a tag to the active span.+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 /local/ 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)++-- | Annotates the active span at the given time.+annotateAt :: MonadTrace m => POSIXTime -> Text -> m ()+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+traceIDHeader = "X-B3-TraceId"+spanIDHeader = "X-B3-SpanId"+parentSpanIDHeader = "X-B3-ParentSpanId"+sampledHeader = "X-B3-Sampled"+debugHeader = "X-B3-Flags"++-- | Serializes the 'B3' to multiple headers, suitable for HTTP requests. All byte-strings are UTF-8+-- encoded.+b3ToHeaders :: B3 -> Map (CI ByteString) ByteString+b3ToHeaders (B3 traceID spanID isSampled isDebug mbParentID) =+ 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 fmap T.encodeUtf8 $ Map.fromList $ defaultKVs ++ parentKVs ++ sampledKVs++-- | Deserializes the 'B3' from multiple headers.+b3FromHeaders :: Map (CI ByteString) ByteString -> Maybe B3+b3FromHeaders hdrs = do+ let+ find key = T.decodeUtf8 <$> 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)+ <*> pure sampled+ <*> pure dbg+ <*> maybe (pure Nothing) (Just <$> decodeSpanID) (find parentSpanIDHeader)++-- | Serializes the 'B3' to a single UTF-8 encoded header value. It will typically be set as+-- <https://github.com/apache/incubator-zipkin-b3-propagation#single-header b3 header>.+b3ToHeaderValue :: B3 -> ByteString+b3ToHeaderValue (B3 traceID spanID isSampled isDebug mbParentID) =+ let+ state = case (isSampled, isDebug) of+ (_ , True) -> "d"+ (True, _) -> "1"+ (False, _) -> "0"+ required = [encodeTraceID traceID, encodeSpanID spanID, state]+ optional = encodeSpanID <$> maybeToList mbParentID+ in BS.intercalate "-" $ fmap T.encodeUtf8 $ required ++ optional++-- | Deserializes a single header value into a 'B3'.+b3FromHeaderValue :: ByteString -> Maybe B3+b3FromHeaderValue bs = case T.splitOn "-" $ T.decodeUtf8 bs of+ (traceIDstr:spanIDstr:strs) -> do+ traceID <- decodeTraceID traceIDstr+ spanID <- decodeSpanID spanIDstr+ let buildB3 = B3 traceID spanID+ case strs of+ [] -> pure $ buildB3 False False Nothing+ (state:strs') -> do+ buildB3' <- case state of+ "0" -> pure $ buildB3 False False+ "1" -> pure $ buildB3 True False+ "d" -> pure $ buildB3 True True+ _ -> Nothing+ case strs' of+ [] -> pure $ buildB3' Nothing+ [str] -> buildB3' . Just <$> decodeSpanID str+ _ -> Nothing+ _ -> Nothing++b3FromSpan :: Span -> B3+b3FromSpan s =+ let+ ctx = spanContext s+ refs = spanReferences s+ in B3 (contextTraceID ctx) (contextSpanID ctx) (spanIsSampled s) (spanIsDebug s) (parentID refs)++-- Builder endos++insertTag :: JSON.ToJSON a => Key -> a -> Endo Builder+insertTag key val =+ Endo $ \bldr -> bldr { builderTags = Map.insert key (JSON.toJSON val) (builderTags bldr) }++importB3 :: B3 -> Endo Builder+importB3 b3 =+ let+ policy = if b3IsDebug b3+ then debugEnabled+ else sampledWhen $ b3IsSampled b3+ in Endo $ \bldr -> bldr+ { builderTraceID = Just (b3TraceID b3)+ , builderSpanID = Just (b3SpanID b3)+ , builderSamplingPolicy = Just policy }++publicKeyPrefix :: Text+publicKeyPrefix = "Z."++-- Remote endpoint tag key.+endpointKey :: Key+endpointKey = "z.e"++-- Kind tag key.+kindKey :: Key+kindKey = "z.k"++-- Internal keys++outgoingSpan :: MonadTrace m => Text -> Endo Builder -> Name -> (Maybe B3 -> m a) -> m a+outgoingSpan kind endo name f = childSpanWith (appEndo endo') name actn where+ endo' = insertTag kindKey kind <> endo+ 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'+-- (or 'Nothing' if tracing is inactive) so that it can be forwarded to the server. For example, to+-- emit an HTTP request and forward the trace information in the headers:+--+-- > import Network.HTTP.Simple+-- >+-- > clientSpan "api-call" $ \(Just b3) -> $ do+-- > res <- httpBS "http://host/api" & addRequestHeader "b3" (b3ToHeaderValue b3)+-- > process res -- Do something with the response.+clientSpan :: MonadTrace m => Name -> (Maybe B3 -> m a) -> m a+clientSpan = clientSpanWith id++-- | Generates a client span, optionally modifying the span's builder. This can be useful in+-- combination with 'addEndpoint' if the remote server does not have tracing enabled.+clientSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> (Maybe B3 -> m a) -> m a+clientSpanWith f = outgoingSpan "CLIENT" (Endo f)++-- | Generates a child span with @PRODUCER@ kind. This function also provides the corresponding 'B3'+-- so that it can be forwarded to the consumer.+producerSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> (Maybe B3 -> m a) -> m a+producerSpanWith f = outgoingSpan "PRODUCER" (Endo f)++incomingSpan :: MonadTrace m => Text -> Endo Builder -> B3 -> m a -> m a+incomingSpan kind endo b3 actn =+ let bldr = appEndo (importB3 b3 <> insertTag kindKey kind <> endo) $ builder ""+ in trace bldr actn++-- | Generates a child span with @SERVER@ kind. The client's 'B3' should be provided as input,+-- for example parsed using 'b3FromHeaders'.+serverSpan :: MonadTrace m => B3 -> m a -> m a+serverSpan = serverSpanWith id++-- | Generates a server span, optionally modifying the span's builder. This can be useful in+-- combination with 'addEndpoint' if the remote client does not have tracing enabled.+serverSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a+serverSpanWith f = incomingSpan "SERVER" (Endo f)++-- | Generates a child span with @CONSUMER@ kind. The producer's 'B3' should be provided as input.+consumerSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a+consumerSpanWith f = incomingSpan "CONSUMER" (Endo f)++-- | Information about a hosted service, included in spans and visible in the Zipkin UI.+data Endpoint = Endpoint+ { endpointService :: !(Maybe Text)+ -- ^ The endpoint's service name.+ , endpointPort :: !(Maybe Int)+ -- ^ The endpoint's port, if applicable and known.+ , endpointIPv4 :: !(Maybe Text)+ -- ^ The endpoint's IPv4 address.+ , endpointIPv6 :: !(Maybe Text)+ -- ^ The endpoint's IPv6 address.+ } deriving (Eq, Ord, Show)++-- | An empty endpoint.+defaultEndpoint :: Endpoint+defaultEndpoint = Endpoint Nothing Nothing Nothing Nothing++-- | Adds a remote endpoint to a builder. This is mostly useful when generating cross-process spans+-- where the remote endpoint is not already traced (otherwise Zipkin will associate the spans+-- correctly automatically). For example when emitting a request to an outside server:+--+-- > clientSpanWith (addEndpoint "outside-api") -- ...+addEndpoint :: Endpoint -> Builder -> Builder+addEndpoint = appEndo . insertTag endpointKey++-- | Generates an endpoint with the given string as service.+instance IsString Endpoint where+ fromString s = defaultEndpoint { endpointService = Just (T.pack s) }++instance JSON.ToJSON Endpoint where+ toJSON (Endpoint mbSvc mbPort mbIPv4 mbIPv6) = JSON.object $ catMaybes+ [ ("serviceName" JSON..=) <$> mbSvc+ , ("port" JSON..=) <$> mbPort+ , ("ipv4" JSON..=) <$> mbIPv4+ , ("ipv6" JSON..=) <$> mbIPv6 ]++parentID :: Set Reference -> Maybe SpanID+parentID = listToMaybe . catMaybes . fmap go . toList where+ go (ChildOf d) = Just d+ go _ = Nothing++data ZipkinAnnotation = ZipkinAnnotation !POSIXTime !JSON.Value++instance JSON.ToJSON ZipkinAnnotation where+ toJSON (ZipkinAnnotation t v) = JSON.object+ [ "timestamp" JSON..= microSeconds @Int64 t+ , "value" JSON..= v ]++-- Internal type used to encode spans in the <https://zipkin.apache.org/zipkin-api/#/ format>+-- expected by Zipkin.+data ZipkinSpan = ZipkinSpan !(Maybe Endpoint) !Sample++publicTags :: Tags -> Map Text JSON.Value+publicTags = Map.fromList . catMaybes . fmap go . Map.assocs where+ go (k, v) = case T.stripPrefix publicKeyPrefix k of+ Nothing -> Nothing+ Just k' -> Just (k', v)++instance JSON.ToJSON ZipkinSpan where+ 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 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 ]+ optionalKVs = catMaybes+ [ ("parentId" JSON..=) <$> parentID (spanReferences spn)+ , ("localEndpoint" JSON..=) <$> mbEpt+ , ("remoteEndpoint" JSON..=) <$> Map.lookup endpointKey tags+ , ("kind" JSON..=) <$> Map.lookup kindKey tags ]+ in JSON.object $ requiredKVs ++ optionalKVs++microSeconds :: Integral a => NominalDiffTime -> a+microSeconds = round . (* 1000000)
+ test/Spec.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++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.Monad (void)+import Control.Monad.Reader (MonadReader, Reader, ReaderT, ask, runReader, runReaderT)+import Control.Monad.State.Strict (MonadState, StateT, evalStateT, get)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Test.Hspec+import Test.Hspec.QuickCheck++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Concurrent.Lifted+import Control.Concurrent.STM.Lifted++collectSpans :: (MonadIO m, MonadBaseControl IO m) => TraceT m () -> m [Span]+collectSpans actn = fmap sampleSpan . snd <$> collectSpanSamples actn++main :: IO ()+main = hspec $ do+ describe "MonadTrace" $ do+ it "should be instantiable with identity-based monads" $ do+ let+ actn :: (MonadReader Int m , MonadState Int m, MonadTrace m) => m Int+ actn = trace "one" $ do+ s <- get+ r <- trace "two" ask+ pure $ s + r+ v = runReader (evalStateT actn 1) 2+ v `shouldBe` 3+ describe "trace" $ do+ it "should not create spans when no traces are started" $ do+ spans <- collectSpans $ pure ()+ fmap spanName spans `shouldBe` []+ it "should collect a single span when no children are created" $ do+ spans <- collectSpans (trace "t" { builderSamplingPolicy = Just alwaysSampled } $ pure ())+ fmap spanName spans `shouldBe` ["t"]+ it "should be able to stack on top of a ReaderT" $ do+ let+ actn = trace "t" { builderSamplingPolicy = Just alwaysSampled } $ do+ name <- ask+ trace (builder name) $ pure ()+ spans <- runReaderT (collectSpans @(ReaderT Text IO) actn) "foo"+ fmap spanName spans `shouldBe` ["foo", "t"]+ describe "Zipkin" $ do+ it "should round-trip a B3 using a single header" $ do+ let+ bs = "80f198ee56343ba864fe8b2a57d3eff7-e457b5a2e4d86bd1-1-05e3ac9a4f6e3b90"+ mbBs = ZPK.b3ToHeaderValue <$> ZPK.b3FromHeaderValue bs+ mbBs `shouldBe` Just bs+ it "should have equivalent B3 header representations" $ do+ let+ bs = "80f198ee56343ba864fe8b2a57d3eff7-e457b5a2e4d86bd1-1-05e3ac9a4f6e3b90"+ hdrs = Map.fromList+ [ ("X-B3-TraceId", "80f198ee56343ba864fe8b2a57d3eff7")+ , ("X-B3-SpanId", "e457b5a2e4d86bd1")+ , ("X-B3-ParentSpanId", "05e3ac9a4f6e3b90")+ , ("X-B3-Sampled", "1") ]+ Just b3 = ZPK.b3FromHeaderValue bs+ Just b3' = ZPK.b3FromHeaders hdrs+ b3 `shouldBe` b3'+ describe "collectSpanSamples" $ do+ it "should collect spans which are still pending after the action returns" $ do+ spans <- collectSpans $ rootSpan alwaysSampled "sleep-parent" $ do+ tmv <- newEmptyTMVarIO+ void $ fork $ childSpan "sleep-child" $ atomically (putTMVar tmv ()) >> threadDelay 20000+ void $ atomically $ readTMVar tmv+ fmap spanName spans `shouldMatchList` ["sleep-parent", "sleep-child"]
+ tracing-control.cabal view
@@ -0,0 +1,76 @@+cabal-version: 1.12++name: tracing-control+version: 0.0.6+synopsis: Distributed tracing+description:+ An OpenTracing-compliant, simple, and extensible distributed tracing library.++ This is a fork of <http://hackage.haskell.org/package/tracing tracing> which+ switches from <http://hackage.haskell.org/package/unliftio unliftio> to+ <http://hackage.haskell.org/package/monad-control monad-control>.++category: Web+homepage: https://github.com/serras/tracing+license: BSD3+license-file: LICENSE+author: Matthieu Monsch, Alejandro Serrano+maintainer: alejandro.serrano@47deg.com+copyright: 2020 Matthieu Monsch++build-type: Simple+extra-source-files: README.md++source-repository head+ type: git+ location: https://github.com/serras/tracing++library+ hs-source-dirs: src+ 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+ , base >= 4.9 && < 5+ , base16-bytestring >= 0.1+ , bytestring >= 0.10+ , case-insensitive >= 1.2+ , containers >= 0.6+ , http-client >= 0.5+ , lifted-base >= 0.2+ , monad-control >= 1.0+ , mtl >= 2.2+ , network >= 2.8+ , random >= 1.1+ , stm >= 2.5+ , stm-lifted >= 2.5+ , text >= 1.2+ , time >= 1.8+ , transformers >= 0.5+ , transformers-base >= 0.4+ ghc-options: -Wall+ default-language: Haskell2010++test-suite tracing-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ build-depends:+ base+ , containers+ , hspec >=2.6+ , lifted-base >= 0.2+ , monad-control >= 1.0+ , mtl+ , stm+ , stm-lifted >= 2.5+ , text+ , tracing-control+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010