tracing 0.0.2.1 → 0.0.2.2

raw patch · 9 files changed

+211/−90 lines, 9 filesdep +case-insensitivedep ~hspecdep ~http-clientdep ~ipPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: case-insensitive

Dependency ranges changed: hspec, http-client, ip, network, time

API changes (from Hackage documentation)

Files

• README.md +23/−1
• app/ZipkinExample.hs +1/−1
• src/Control/Monad/Trace.hs +4/−1
• src/Control/Monad/Trace/Class.hs +7/−2
• src/Monitor/Tracing.hs +47/−35
• src/Monitor/Tracing/Jaeger.hs +0/−7
• src/Monitor/Tracing/Zipkin.hs +102/−36
• test/Spec.hs +19/−0
• tracing.cabal +8/−7

@@ -1,1 +1,23 @@-# Distributed tracing+# Tracing++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 implement+  your own.++```haskell+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+```++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 `app/` folder.

@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-| A simple tracing example which publishes traces to a local Zipkin server. -}+-- | A simple tracing example which publishes traces to a local Zipkin server. module Main where  import Control.Monad (void)

@@ -4,7 +4,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance. --- | The 'TraceT' class.+-- | This module is useful 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(..),@@ -49,7 +50,9 @@ -- | A tracer collects spans emitted inside 'TraceT'. data Tracer = Tracer   { tracerChannel :: TChan (Span, Tags, Logs, Interval)+  -- ^ Channel spans get written to when they complete.   , tracerPendingCount :: TVar Int+  -- ^ The number of spans currently in flight (started but not yet completed).   }  -- | Creates a new 'Tracer'.

@@ -3,7 +3,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} --- | The 'MonadTrace' class+-- | This module exposes the generic 'MonadTrace' class. module Control.Monad.Trace.Class (   -- * Generating traces   MonadTrace(..),@@ -16,6 +16,9 @@   Builder(..), Name, builder,   Sampling, alwaysSampled, neverSampled, sampledEvery, sampledWhen, debugEnabled,   -- * Annotating spans+  -- | 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 @@ -144,7 +147,9 @@ sampledEvery :: Int -> Sampling sampledEvery n = WithProbability (1 / fromIntegral n) --- | Returns a 'Sampling' which samples a span iff the input is 'True'.+-- | Returns a 'Sampling' 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 

@@ -1,43 +1,55 @@-{-| Non-intrusive distributed tracing--Let's assume for example 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 a 'childSpan' call 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---}+-- | 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++  -- * Generic trace creation   MonadTrace,-  -- * Generic span creation+  -- ** Controlling the sampling rate   Sampling, alwaysSampled, neverSampled, sampledEvery, sampledWhen, debugEnabled,-  rootSpan, rootSpanWith, childSpan, childSpanWith,+  -- ** Building hierarchical traces+  -- | 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 the lineage of spans is+  -- automatically propagated.+  rootSpan, childSpan,+   -- * Backends+  -- | As a convenience, the top-level type for each backend is exported here.   Zipkin ) where 

@@ -1,7 +0,0 @@-{-| <https://www.jaegertracing.io/ Jaeger> trace publisher. -}-module Monitor.Tracing.Jaeger (-  Jaeger-) where---- | Jaeger publisher, not implemented yet.-data Jaeger

@@ -4,15 +4,27 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-| <https://zipkin.apache.org/ Zipkin> trace publisher. -}+-- | This module implements a <https://zipkin.apache.org/ Zipkin>-powered trace publisher. You will+-- almost certainly want to import it qualified. module Monitor.Tracing.Zipkin (-  -- * Set up the trace collector+  -- * Configuration+  -- ** General settings+  Settings, defaultSettings, settingsHostname, settingsPort, settingsManager, settingsEndpoint,+  settingsPublishPeriod,+  -- ** Endpoint+  Endpoint, defaultEndpoint, endpointService, endpointPort, endpointIPv4, endpointIPv6,++  -- * Publishing traces   Zipkin,-  new, Settings(..), defaultSettings, Endpoint(..), defaultEndpoint,-  run, publish, with,-  -- * Record cross-process spans-  B3, b3FromHeaders, b3ToHeaders, clientSpan, serverSpan, producerSpan, consumerSpan,-  -- * Add metadata+  new, run, publish, with,++  -- * Cross-process spans+  -- ** Communication+  B3, b3ToHeaders, b3FromHeaders, b3ToHeaderValue, b3FromHeaderValue,+  -- ** Span generation+  clientSpan, serverSpan, producerSpan, consumerSpan,++  -- * Custom metadata   tag, annotate, annotateAt ) where @@ -25,7 +37,9 @@ import Control.Monad.Fix (fix) import Control.Monad.IO.Class (MonadIO, liftIO) 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)@@ -35,8 +49,10 @@ import Data.Maybe (catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) import Data.Monoid ((<>), Endo(..)) 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 Net.IPv4 (IPv4) import Net.IPv6 (IPv6)@@ -46,25 +62,33 @@ import UnliftIO (MonadUnliftIO) import UnliftIO.Exception (finally) --- | Zipkin creating settings.+-- | '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. data Settings = Settings   { settingsHostname :: !(Maybe HostName)-  -- ^ The Zipkin server's hostname.+  -- ^ The Zipkin server's hostname, defaults to @localhost@ if unset.   , settingsPort :: !(Maybe PortNumber)-  -- ^ The port the Zipkin server is listening on.+  -- ^ The port the Zipkin server is listening on, defaults to @9411@ if unset.   , settingsEndpoint :: !(Maybe Endpoint)-  -- ^ Local endpoint used for all published spans.+  -- ^ 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 'Settings' pointing to a Zikpin server at host @"localhost"@ and port @9411@, without--- background flushing.+-- | 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. data Zipkin = Zipkin   { zipkinManager :: !Manager@@ -82,8 +106,9 @@       when (spanIsSampled 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+  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@@ -136,21 +161,22 @@ data B3 = B3   { b3TraceID :: !TraceID   , b3SpanID :: !SpanID-  , b3ParentSpanID :: !(Maybe SpanID)   , b3IsSampled :: !Bool   , b3IsDebug :: !Bool-  } deriving (Eq, Show)+  , b3ParentSpanID :: !(Maybe SpanID)+  } deriving (Eq, Ord, Show) -traceIDHeader, spanIDHeader, parentSpanIDHeader, sampledHeader, debugHeader :: Text+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 headers, suitable for HTTP requests.-b3ToHeaders :: B3 -> Map Text Text-b3ToHeaders (B3 traceID spanID mbParentID isSampled isDebug) =+-- | 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@@ -158,13 +184,13 @@       (_, True) -> [(debugHeader, "1")]       (True, _) -> [(sampledHeader, "1")]       (False, _) -> [(sampledHeader, "0")]-  in Map.fromList $ defaultKVs ++ parentKVs ++ sampledKVs+  in fmap T.encodeUtf8 $ Map.fromList $ defaultKVs ++ parentKVs ++ sampledKVs --- | Deserializes the 'B3' from headers.-b3FromHeaders :: Map Text Text -> Maybe B3+-- | Deserializes the 'B3' from multiple headers.+b3FromHeaders :: Map (CI ByteString) ByteString -> Maybe B3 b3FromHeaders hdrs = do   let-    find key = Map.lookup key hdrs+    find key = T.decodeUtf8 <$> Map.lookup key hdrs     findBool def key = case find key of       Nothing -> Just def       Just "1" -> Just True@@ -176,24 +202,50 @@   B3     <$> (find traceIDHeader >>= decodeTraceID)     <*> (find spanIDHeader >>= decodeSpanID)-    <*> maybe (pure Nothing) (Just <$> decodeSpanID) (find parentSpanIDHeader)     <*> pure sampled     <*> pure dbg+    <*> maybe (pure Nothing) (Just <$> decodeSpanID) (find parentSpanIDHeader) -instance JSON.FromJSON B3 where-  parseJSON = JSON.withObject "B3" $ \v -> do-    hdrs <- JSON.parseJSON (JSON.Object v)-    maybe (fail "bad input") pure $ b3FromHeaders hdrs+-- | 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 -instance JSON.ToJSON B3 where-  toJSON = JSON.toJSON . b3ToHeaders+-- | 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) (parentID refs) (spanIsSampled s) (spanIsDebug s)+  in B3 (contextTraceID ctx) (contextSpanID ctx) (spanIsSampled s) (spanIsDebug s) (parentID refs)  -- Builder endos @@ -233,7 +285,12 @@     Just spn -> f $ Just $ b3FromSpan spn  -- | Generates a child span with @CLIENT@ kind. This function also provides the corresponding 'B3'--- so that it can be forwarded to the server.+-- (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:+--+-- > clientSpan "api-call" $ \(Just b3) -> $ do+-- >   res <- httpLbs "http://host/api" { requestHeaders = b3ToHeaders b3 }+-- >   process res -- Do something with the response. clientSpan :: MonadTrace m => Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a clientSpan = outgoingSpan "CLIENT" @@ -249,7 +306,8 @@     bldr = appEndo endo $ builder ""   in trace bldr actn --- | Generates a child span with @SERVER@ kind. The client's 'B3' should be provided as input.+-- | Generates a child span with @SERVER@ kind. The client's 'B3' should be provided as input,+-- for example parsed using 'b3FromRequestHeaders'. serverSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a serverSpan = incomingSpan "SERVER" @@ -257,17 +315,25 @@ consumerSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a consumerSpan = incomingSpan "CONSUMER" --- | Information about a hosted service.+-- | 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 IPv4)+  -- ^ The endpoint's IPv4 address.   , endpointIPv6 :: !(Maybe IPv6)+  -- ^ The endpoint's IPv6 address.   } deriving (Eq, Ord, Show)  -- | An empty endpoint. defaultEndpoint :: Endpoint defaultEndpoint = Endpoint Nothing Nothing Nothing Nothing++-- | 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

@@ -6,6 +6,7 @@ import Control.Monad.Trace import Control.Monad.Trace.Class import Monitor.Tracing+import qualified Monitor.Tracing.Zipkin as ZPK  import Control.Concurrent import Control.Concurrent.STM (atomically, tryReadTChan)@@ -14,6 +15,7 @@ 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 import Test.Hspec.QuickCheck@@ -56,3 +58,20 @@           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'

@@ -1,5 +1,5 @@ name:                tracing-version:             0.0.2.1+version:             0.0.2.2 synopsis:            Distributed tracing description:         https://github.com/mtth/tracing homepage:            https://github.com/mtth/tracing@@ -18,22 +18,22 @@   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+                     , case-insensitive >= 1.2 && < 1.3                      , containers >= 0.6 && < 0.7-                     , http-client >= 0.5 && < 0.6-                     , ip >= 1.4 && < 1.5+                     , http-client >= 0.5 && < 0.7+                     , ip >= 1.4 && < 1.6                      , mtl >= 2.2 && < 2.3-                     , network >= 2.8 && < 2.9+                     , network >= 2.8 && < 3.2                      , random >= 1.1 && < 1.2                      , stm >= 2.5 && < 2.6                      , text >= 1.2 && < 1.3-                     , time >= 1.8 && < 1.9+                     , time >= 1.8 && < 1.10                      , transformers >= 0.5 && < 0.6                      , unliftio >= 0.2 && < 0.3   default-language:    Haskell2010@@ -46,7 +46,8 @@       test   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:       base >=4.8 && <5-                     , hspec >=2.6 && <2.7+                     , containers >= 0.6 && < 0.7+                     , hspec >=2.6 && <2.8                      , mtl >= 2.2 && < 2.3                      , stm >= 2.5 && < 2.6                      , text >= 1.2 && < 1.3