packages feed

tracing (empty) → 0.0.1.0

raw patch · 12 files changed

+993/−0 lines, 12 filesdep +aesondep +basedep +base16-bytestringsetup-changed

Dependencies added: aeson, base, base16-bytestring, bytestring, containers, hspec, http-client, ip, mtl, random, stm, text, time, tracing, transformers, unliftio

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Matthieu Monsch (c) 2019++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,1 @@+# Distributed tracing
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/ZipkinExample.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | A simple tracing example which outputs traces to stdout.+--+-- It also showcases how to trace calls across threads.+module Main where++import Control.Concurrent (threadDelay)+import Control.Monad (void)+import Monitor.Tracing+import qualified Monitor.Tracing.Zipkin as Zipkin+import qualified Net.IPv4 as IPv4++example1 :: MonadTrace m => m ()+example1 = Zipkin.rootSpan Zipkin.Deny "example1" $ do+  Zipkin.annotate "TEST_LOG0"+  Zipkin.localSpan "nested1" $ Zipkin.tag "TEST_TAG1" "12"+  Zipkin.localSpan "nested2" $ do+    Zipkin.tag "TEST_TAG2" "a.2"+    Zipkin.localSpan "nestednsted" $ Zipkin.tag "TEST_TAG3" ""++example2 :: (MonadTrace m, MonadUnliftIO m) => m ()+example2 = Zipkin.rootSpan Zipkin.Accept "something" $ do+  Zipkin.annotate "log2"+  Zipkin.tag "tag2" "def"+  liftIO $ threadDelay 100000+  Zipkin.localSpan "A" $ do+    void $ tracedForkIO $ Zipkin.localSpan "aa" $ do+      liftIO $ threadDelay 20000+      Zipkin.annotate "log1"+      Zipkin.tag "tag1" "def"+    liftIO $ threadDelay 10000+  Zipkin.localSpan "B" $ liftIO $ threadDelay 30000++main :: IO ()+main = do+  zipkin <- Zipkin.new $ Zipkin.defaultSettings+    { Zipkin.settingsEndpoint = Just $ Zipkin.defaultEndpoint+      { Zipkin.endpointService = Just "print-spans"+      , Zipkin.endpointIPv4 = Just IPv4.localhost }+    , Zipkin.settingsHost = "localhost" }+  Zipkin.run zipkin example1+  Zipkin.run zipkin example2+  Zipkin.publish zipkin
+ src/Control/Monad/Trace.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance.++-- | The 'TraceT' class.+module Control.Monad.Trace (+  TraceT, runTraceT,+  Tracer(..),+  Tags, Logs, Interval(..),+  newTracer+) where++import Prelude hiding (span)++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)+import Control.Monad.Trans.Class (MonadTrans(..))+import qualified Data.Aeson as JSON+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)+import UnliftIO (MonadUnliftIO, UnliftIO(..), askUnliftIO, withRunInIO, withUnliftIO)++-- | A collection of span tags.+type Tags = Map Key JSON.Value++-- | A collection of span logs, sorted in chronological order.+type Logs = [(POSIXTime, Key, JSON.Value)]++-- | Timing information about a span.+data Interval = Interval+  { intervalStart :: !POSIXTime+  , intervalDuration :: !NominalDiffTime+  }++-- | A tracer collects spans emitted inside 'TraceT'.+data Tracer = Tracer+  { tracerChannel :: TChan (Span, Tags, Logs, Interval)+  , tracerPendingCount :: TVar Int+  }++-- | Creates a new 'Tracer'.+newTracer :: MonadIO m => m Tracer+newTracer = liftIO $ Tracer <$> newTChanIO <*> newTVarIO 0++data Scope = Scope+  { scopeTracer :: !Tracer+  , scopeSpan :: !(Maybe Span)+  , scopeTags :: !(Maybe (TVar Tags))+  , scopeLogs :: !(Maybe (TVar Logs))+  }++-- | Asynchronous trace collection monad.+newtype TraceT m a = TraceT { traceTReader :: ReaderT Scope m a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)++instance MonadReader r m => MonadReader r (TraceT m) where+  ask = lift ask+  local f (TraceT (ReaderT g)) = TraceT $ ReaderT $ \r -> local f $ g r++instance MonadUnliftIO m => MonadTrace (TraceT m) where+  trace bldr (TraceT reader) = TraceT $ do+    parentScope <- ask+    let+      mbParentCtx = spanContext <$> scopeSpan parentScope+      mbTraceID = contextTraceID <$> mbParentCtx+    spanID <- maybe (liftIO randomSpanID) pure $ builderSpanID bldr+    traceID <- maybe (liftIO randomTraceID) pure $ builderTraceID bldr <|> mbTraceID+    tagsTV <- liftIO $ newTVarIO $ builderTags bldr+    logsTV <- liftIO $ newTVarIO []+    let+      baggages = fromMaybe Map.empty $ contextBaggages <$> mbParentCtx+      ctx = Context traceID spanID (builderBaggages bldr `Map.union` baggages)+      spn = Span (builderName bldr) ctx (builderReferences bldr)+      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))++  activeSpan = TraceT $ asks scopeSpan++  addSpanEntry key (TagValue val) = TraceT $ asks scopeTags >>= \case+    Nothing -> pure ()+    Just tv -> liftIO $ 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) :)++instance MonadUnliftIO m => MonadUnliftIO (TraceT m) where+  askUnliftIO = TraceT $ withUnliftIO $ \u -> pure (UnliftIO (unliftIO u . traceTReader ))++-- | Trace an action.+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,140 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- | The 'MonadTrace' class+module Control.Monad.Trace.Class (+  MonadTrace(..),+  Builder(..), Name, SpanID, TraceID, Reference(..), builder,+  Span(..), Context(..),+  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)++-- | A monad capable of generating traces.+--+-- There are currently two instances of this monad:+--+-- * '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.+  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 (Monad m, MonadTrace m) => MonadTrace (ExceptT e m) where+  trace name (ExceptT actn) = ExceptT $ trace name actn++instance (Monad m, MonadTrace m) => MonadTrace (ReaderT r m) where+  trace name (ReaderT actn) = ReaderT $ \r -> trace name (actn r)++instance (Monad m, 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 (Monad m, 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 (Monad m, MonadTrace m) => MonadTrace (State.Lazy.StateT s m) where+  trace name (State.Lazy.StateT actn) = State.Lazy.StateT $ \s -> trace name (actn s)++instance (Monad m, MonadTrace m) => MonadTrace (State.Strict.StateT s m) where+  trace name (State.Strict.StateT actn) = State.Strict.StateT $ \s -> trace name (actn s)++instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (Writer.Lazy.WriterT w m) where+  trace name (Writer.Lazy.WriterT actn) = Writer.Lazy.WriterT $ trace name actn++instance (Monad m, 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 trace builder.+--+-- Note that 'Builder' has an 'IsString' instance, producing a span with the given string as name,+-- no additional references, tags, or baggages. This allows convenient creation of spans via the+-- @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.+  } deriving Show++-- | 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++instance IsString Builder where+  fromString = builder . T.pack++-- 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,107 @@+{-# LANGUAGE OverloadedStrings #-}++module Control.Monad.Trace.Internal (+  TraceID(..), randomTraceID,+  SpanID(..), randomSpanID,+  Context(..),+  Name,+  Span(..),+  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)++instance JSON.FromJSON TraceID where+  parseJSON = JSON.withText "TraceID" $ \t -> case hexDecode t of+    Just bs | BS.length bs == 16 -> pure $ TraceID bs+    _ -> fail "invalid hex-encoded trace ID"++instance JSON.ToJSON TraceID where+  toJSON (TraceID bs) = JSON.toJSON $ hexEncode bs++-- | 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)++instance JSON.FromJSON SpanID where+  parseJSON = JSON.withText "SpanID" $ \t -> case hexDecode t of+    Just bs | BS.length bs == 8 -> pure $ SpanID bs+    _ -> fail "invalid hex-encoded span ID"++instance JSON.ToJSON SpanID where+  toJSON (SpanID bs) = JSON.toJSON $ hexEncode bs++-- | 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. Span contexts can be exported (resp. imported) via their 'JSON.toJSON' (resp.+-- 'JSON.fromJSON') instance.+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)+  }++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,55 @@+{-| Non-intrusive distributed tracing++Let's assume for example we are interested in tracing the two following functions and publishing+their traces to Zipkin:++> 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 a 'Monitor.Tracing.Zipkin.localSpan' call and adding a+'MonadTrace' constraint:++> listTaskIDs' :: (MonadIO m, MonadTrace m) => m [Int]+> listTaskIDs' = localSpan "list-task-ids" listTaskIDs+>+> fetchTasks' :: (MonadIO m, MonadTrace m) => [Int] -> m [Task]+> fetchTasks' = localSpan "fetch-tasks" . fetchTasks++Spans will now automatically get generated and published each time these actions are run! Each+publication will include various useful pieces of metadata, including lineage. For example, if we+wrap the two above functions in a root span, the spans will correctly be nested:++> main :: IO ()+> main = do+>   zipkin <- new defaultSettings+>   tasks <- run zipkin $ rootSpan "list-tasks" (listTaskIDs' >>= fetchTasks')+>   publish zipkin+>   print tasks++For clarity the above example imported all functions unqualified. In general, the recommended+pattern when using this library is to import this module unqualified and the backend-specific module+qualified. For example:++> import Monitor.Tracing+> import qualified Monitor.Tracing.Zipkin as Zipkin++-}+module Monitor.Tracing (+  -- * Overview+  MonadTrace, tracedForkIO,+  -- * Convenience exports+  MonadIO, liftIO, MonadUnliftIO, withRunInIO+) where++import Control.Monad.Trace.Class++import Control.Concurrent (forkIO, ThreadId)+import Control.Monad.IO.Class (MonadIO, liftIO)+import UnliftIO (MonadUnliftIO, withRunInIO)++-- | Starts a new span inside a new thread, returning the newly created thread's ID.+--+-- This convenience method around 'forkIO' and 'withRunInIO' is provided since getting insights into+-- concurrent calls is one of the main benefits of tracing.+tracedForkIO :: (MonadTrace m, MonadUnliftIO m) => m () -> m ThreadId+tracedForkIO actn = withRunInIO $ \run -> forkIO $ run actn
+ src/Monitor/Tracing/Jaeger.hs view
@@ -0,0 +1,7 @@+{-| <https://www.jaegertracing.io/ Jaeger> trace publisher. -}+module Monitor.Tracing.Jaeger (+  Jaeger+) where++-- | Jaeger publisher, not implemented yet.+data Jaeger
+ src/Monitor/Tracing/Zipkin.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{-| <https://zipkin.apache.org/ Zipkin> trace publisher. -}+module Monitor.Tracing.Zipkin (+  -- * Set up the trace collector+  Zipkin, new, Settings(..), defaultSettings, Endpoint(..), defaultEndpoint, run, publish,+  -- * Record in-process spans+  rootSpan, Sampling(..), localSpan,+  -- * Record cross-process spans+  B3, clientSpan, serverSpan, producerSpan, consumerSpan,+  -- * Add metadata+  tag, annotate, annotateAt+) where++import Control.Monad.Trace+import Control.Monad.Trace.Class++import Control.Applicative ((<|>))+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM (atomically, tryReadTChan)+import Control.Monad (forever, void, when)+import Control.Monad.Fix (fix)+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Aeson as JSON+import Data.ByteString (ByteString)+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, maybe, maybeToList)+import Data.Monoid (Endo(..))+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Clock.POSIX (POSIXTime)+import Net.IPv4 (IPv4)+import Net.IPv6 (IPv6)+import Network.HTTP.Client (Manager, Request)+import qualified Network.HTTP.Client as HTTP++-- | Zipkin creating settings.+data Settings = Settings+  { settingsManager :: !(Maybe Manager)+  -- ^ An optional HTTP manager to use for publishing spans on the Zipkin server.+  , settingsHost :: !ByteString+  -- ^ The Zipkin server host.+  , settingsPort :: !Int+  -- ^ The port the Zipkin server is listening on.+  , settingsEndpoint :: !(Maybe Endpoint)+  -- ^ Local endpoint used for all published spans.+  , settingsPublishPeriod :: !NominalDiffTime+  -- ^ If set to a positive value, traces will be flushed in the background every such period.+  }++-- | Creates 'Settings' pointing to a Zikpin server at host @"localhost"@ and port @9411@, without+-- background flushing.+defaultSettings :: Settings+defaultSettings = Settings Nothing "localhost" 9411 Nothing 0++-- | A Zipkin trace publisher.+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 $ tracerChannel tracer) >>= \case+    Nothing -> pure ()+    Just (spn, tags, logs, itv) -> do+      when (isSampled spn) $ modifyIORef ref (ZipkinSpan ept spn tags logs itv:)+      loop+  spns <- readIORef ref+  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 mbMgr host port mbEpt prd) = liftIO $ do+  mgr <- maybe (HTTP.newManager HTTP.defaultManagerSettings) pure mbMgr+  tracer <- newTracer+  let+    req = HTTP.defaultRequest+      { HTTP.method = "POST"+      , HTTP.host = host+      , HTTP.path = "/api/v2/spans"+      , HTTP.port = port }+  void $ 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 :: Zipkin -> TraceT m a -> m a+run zipkin actn = runTraceT actn (zipkinTracer zipkin)++-- | Flushes all complete spans to the Zipkin server. This method is thread-safe.+publish :: MonadIO m => Zipkin -> m ()+publish z =+  liftIO $ flushSpans (zipkinEndpoint z) (zipkinTracer z) (zipkinRequest z) (zipkinManager z)++-- | Adds a tag to the active span.+tag :: MonadTrace m => Text -> Text -> m ()+tag key val = addSpanEntry (publicKeyPrefix <> key) (tagTextValue val)++-- | 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+  , b3SpanID :: !SpanID+  , b3ParentSpanID :: !(Maybe SpanID)+  , b3Sampling :: !(Maybe Sampling)+  } deriving (Eq, Show)++b3FromSpan :: Span -> B3+b3FromSpan s =+  let+    ctx = spanContext s+    samplingState = if fromMaybe False (lookupBoolBaggage debugKey ctx)+      then Just Debug+      else explicitSamplingState <$> lookupBoolBaggage samplingKey ctx+  in B3 (contextTraceID ctx) (contextSpanID ctx) (parentID $ spanReferences s) samplingState++-- Builder endos++insertBaggage :: Key -> ByteString -> Endo Builder+insertBaggage key val =+  Endo $ \bldr -> bldr { builderBaggages = Map.insert key val (builderBaggages bldr) }++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+    baggages = Map.fromList $ case b3Sampling b3 of+      Just Accept -> [(samplingKey, "1")]+      Just Deny -> [(samplingKey, "0")]+      Just Debug -> [(debugKey, "1")]+      Nothing -> []+  in Endo $ \bldr -> bldr+    { builderTraceID = Just (b3TraceID b3)+    , builderSpanID = Just (b3SpanID b3)+    , builderBaggages = baggages }++-- | The sampling applied to a trace.+--+-- Note that non-sampled traces still yield active spans. However these spans are not published to+-- Zipkin.+data Sampling+  = Accept+  -- ^ Sample it.+  | Debug+  -- ^ Sample it and mark it as debug.+  | Deny+  -- ^ Do not sample it.+  deriving (Eq, Ord, Enum, Show)++applySampling :: Sampling -> Endo Builder+applySampling Accept = insertBaggage samplingKey "1"+applySampling Debug = insertBaggage debugKey "1"+applySampling Deny = insertBaggage samplingKey "0"++isSampled :: Span -> Bool+isSampled spn =+  let ctx = spanContext spn+  in fromMaybe False $ lookupBoolBaggage debugKey ctx <|> lookupBoolBaggage samplingKey ctx++publicKeyPrefix :: Text+publicKeyPrefix = "Z."++-- Debug baggage key.+debugKey :: Key+debugKey = "z.d"++-- Sampling baggage key.+samplingKey :: Key+samplingKey = "z.s"++-- Remote endpoint tag key.+endpointKey :: Key+endpointKey = "z.e"++-- Kind tag key.+kindKey :: Key+kindKey = "z.k"++-- Internal keys++-- | Starts a new trace.+rootSpan :: MonadTrace m => Sampling -> Name -> m a -> m a+rootSpan sampling name = trace $ appEndo (applySampling sampling) $ builder name++childSpan :: MonadTrace m => Endo Builder -> Name -> m a -> m a+childSpan endo name actn = activeSpan >>= \case+  Nothing -> actn+  Just spn -> do+    let+      ctx = spanContext spn+      bldr = (builder name)+        { builderTraceID = Just $ contextTraceID ctx+        , builderReferences = Set.singleton (ChildOf $ contextSpanID ctx) }+    trace (appEndo endo $ bldr) actn++-- | Continues an existing trace if present, otherwise does nothing.+localSpan :: MonadTrace m => Name -> m a -> m a+localSpan = childSpan mempty++outgoingSpan :: MonadTrace m => Text -> Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a+outgoingSpan kind mbEpt name f = childSpan endo name actn where+  endo = insertTag kindKey kind <> maybe mempty (insertTag endpointKey) mbEpt+  actn = activeSpan >>= \case+    Nothing -> f Nothing+    Just spn -> f $ Just $ b3FromSpan spn++clientSpan :: MonadTrace m => Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a+clientSpan = outgoingSpan "CLIENT"++producerSpan :: MonadTrace m => Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a+producerSpan = outgoingSpan "PRODUCER"++incomingSpan :: MonadTrace m => Text -> Maybe Endpoint -> B3 -> m a -> m a+incomingSpan kind mbEpt b3 actn =+  let+    endo = importB3 b3 <> insertTag kindKey kind <> maybe mempty (insertTag endpointKey) mbEpt+    bldr = appEndo endo $ builder ""+  in trace bldr actn++serverSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a+serverSpan = incomingSpan "SERVER"++consumerSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a+consumerSpan = incomingSpan "CONSUMER"++-- | Information about a hosted service.+data Endpoint = Endpoint+  { endpointService :: !(Maybe Text)+  , endpointPort :: !(Maybe Int)+  , endpointIPv4 :: !(Maybe IPv4)+  , endpointIPv6 :: !(Maybe IPv6)+  } deriving (Eq, Ord, Show)++-- | An empty endpoint.+defaultEndpoint :: Endpoint+defaultEndpoint = Endpoint Nothing Nothing Nothing Nothing++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 ]++explicitSamplingState :: Bool -> Sampling+explicitSamplingState True = Accept+explicitSamplingState False = Deny++lookupBoolBaggage :: Key -> Context -> Maybe Bool+lookupBoolBaggage key ctx = Map.lookup key (contextBaggages ctx) >>= \case+  "0" -> Just False+  "1" -> Just True+  _ -> Nothing++parentID :: Set Reference -> Maybe SpanID+parentID = listToMaybe . catMaybes . fmap go . toList where+  go (ChildOf d) = Just d+  go _ = Nothing++traceIDHeader, spanIDHeader, parentSpanIDHeader, sampledHeader, debugHeader :: Text+traceIDHeader = "X-B3-TraceId"+spanIDHeader = "X-B3-SpanId"+parentSpanIDHeader = "X-B3-ParentSpanId"+sampledHeader = "X-B3-Sampled"+debugHeader = "X-B3-Flags"++instance JSON.FromJSON B3 where+  parseJSON = JSON.withObject "B3" $ \v -> do+    dbg <- v JSON..:! debugHeader JSON..!= False+    state <- fmap explicitSamplingState <$> v JSON..:! sampledHeader+    let+      sampling = case (dbg, state) of+        (False, s) -> pure s+        (True, Nothing) -> pure (Just Debug)+        _ -> fail "bad debug and sampling combination"+    B3+      <$> v JSON..: traceIDHeader+      <*> v JSON..: spanIDHeader+      <*> v JSON..:! parentSpanIDHeader+      <*> sampling++instance JSON.ToJSON B3 where+  toJSON (B3 traceID spanID mbParentID state) =+    let+      defaultKVs = [traceIDHeader JSON..= traceID, spanIDHeader JSON..= spanID]+      parentKVs = (parentSpanIDHeader JSON..=) <$> maybeToList mbParentID+      sampledKVs = case state of+        Nothing -> []+        Just Debug -> [debugHeader JSON..= ("1" :: Text)]+        Just Accept -> [sampledHeader JSON..= ("1" :: Text)]+        Just Deny -> [sampledHeader JSON..= ("0" :: Text)]+    in JSON.object $ defaultKVs ++ parentKVs ++ sampledKVs++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) !Span !Tags !Logs !Interval++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 spn tags logs itv) =+    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)+        , "debug" JSON..= fromMaybe False (lookupBoolBaggage debugKey ctx)+        , "tags" JSON..= publicTags tags+        , "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,58 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++import Control.Monad.Trace+import Control.Monad.Trace.Class+import Monitor.Tracing++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 Data.Text (Text)+import Test.Hspec+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)++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 @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"]+    it "should be able to stack on top of a ReaderT" $ do+      spans <- (collectSpans @IO) $ trace "c2" $ pure ()+      let+        actn = trace "t" $ do+          name <- ask+          trace (builder name) $ pure ()+      spans <- runReaderT (collectSpans @(ReaderT Text IO) actn) "foo"+      fmap spanName spans `shouldBe` ["foo", "t"]
+ tracing.cabal view
@@ -0,0 +1,68 @@+name:                tracing+version:             0.0.1.0+synopsis:            Distributed tracing+description:         https://github.com/mtth/tracing+homepage:            https://github.com/mtth/tracing+license:             BSD3+license-file:        LICENSE+author:              Matthieu Monsch+maintainer:          matthieu.monsch@gmail.com+copyright:           2019 Matthieu Monsch+category:            Web+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:  README.md++library+  hs-source-dirs:      src+  exposed-modules:     Control.Monad.Trace+                     , Control.Monad.Trace.Class+                     , Monitor.Tracing+                     , Monitor.Tracing.Jaeger+                     , Monitor.Tracing.Zipkin+  other-modules:       Control.Monad.Trace.Internal+  build-depends:       aeson >= 1.4 && < 1.5+                     , base >= 4.8 && < 5+                     , base16-bytestring >= 0.1 && < 0.2+                     , bytestring >= 0.10 && < 0.11+                     , containers >= 0.6 && < 0.7+                     , http-client >= 0.5 && < 0.6+                     , ip >= 1.4 && < 1.5+                     , mtl >= 2.2 && < 2.3+                     , random >= 1.1 && < 1.2+                     , stm >= 2.5 && < 2.6+                     , text >= 1.2 && < 1.3+                     , time >= 1.8 && < 1.9+                     , transformers >= 0.5 && < 0.6+                     , unliftio >= 0.2 && < 0.3+  default-language:    Haskell2010+  ghc-options:         -Wall++test-suite tracing-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base >=4.8 && <5+                     , hspec >=2.6 && <2.7+                     , mtl >= 2.2 && < 2.3+                     , stm >= 2.5 && < 2.6+                     , text >= 1.2 && < 1.3+                     , tracing+                     , unliftio >= 0.2 && < 0.3+  default-language: Haskell2010++executable zipkin-example+  hs-source-dirs:      app+  main-is:             ZipkinExample.hs+  build-depends:       aeson >= 1.4 && < 1.5+                     , base >=4.8 && <5+                     , bytestring >= 0.10 && < 0.11+                     , containers >= 0.6 && < 0.7+                     , ip >= 1.4 && < 1.5+                     , stm >= 2.5 && < 2.6+                     , text >= 1.2 && < 1.3+                     , tracing+                     , unliftio >= 0.2 && < 0.3+  default-language:    Haskell2010