diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/app/ZipkinExample.hs b/app/ZipkinExample.hs --- a/app/ZipkinExample.hs +++ b/app/ZipkinExample.hs @@ -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) diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -4,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'. diff --git a/src/Control/Monad/Trace/Class.hs b/src/Control/Monad/Trace/Class.hs --- a/src/Control/Monad/Trace/Class.hs +++ b/src/Control/Monad/Trace/Class.hs @@ -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 diff --git a/src/Monitor/Tracing.hs b/src/Monitor/Tracing.hs --- a/src/Monitor/Tracing.hs +++ b/src/Monitor/Tracing.hs @@ -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 diff --git a/src/Monitor/Tracing/Jaeger.hs b/src/Monitor/Tracing/Jaeger.hs deleted file mode 100644 --- a/src/Monitor/Tracing/Jaeger.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-| trace publisher. -} -module Monitor.Tracing.Jaeger ( - Jaeger -) where - --- | Jaeger publisher, not implemented yet. -data Jaeger diff --git a/src/Monitor/Tracing/Zipkin.hs b/src/Monitor/Tracing/Zipkin.hs --- a/src/Monitor/Tracing/Zipkin.hs +++ b/src/Monitor/Tracing/Zipkin.hs @@ -4,15 +4,27 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-| trace publisher. -} +-- | This module implements a -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 +-- . +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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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' diff --git a/tracing.cabal b/tracing.cabal --- a/tracing.cabal +++ b/tracing.cabal @@ -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