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 @@ -14,7 +14,7 @@ module Control.Monad.Trace ( -- * Tracers Tracer, newTracer, - runTraceT, TraceT(..), + runTraceT, runTraceT', TraceT(..), -- * Collected data -- | Tracers currently expose two pieces of data: completed spans and pending span count. Note @@ -111,7 +111,7 @@ } -- | A span generation monad. -newtype TraceT m a = TraceT { traceTReader :: ReaderT Scope m a } +newtype TraceT m a = TraceT { traceTReader :: ReaderT (Maybe Scope) m a } deriving ( Functor, Applicative, Monad, MonadTrans , MonadWriter w, MonadState s, MonadError e , MonadIO, MonadBase b ) @@ -125,61 +125,62 @@ 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) + = coerce @((RunInBase (ReaderT (Maybe Scope) m) b -> b a) -> ReaderT (Maybe 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) + = coerce @(StM (ReaderT (Maybe Scope) m) a -> ReaderT (Maybe 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 + trace bldr (TraceT reader) = TraceT $ ask >>= \case + Nothing -> reader + Just parentScope -> do + 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 $ Just $ 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 $ Just $ Scope tracer (Just spn) Nothing Nothing) reader - activeSpan = TraceT $ asks scopeSpan + activeSpan = TraceT $ asks (>>= scopeSpan) addSpanEntry key (TagValue val) = TraceT $ do - mbTV <- asks scopeTags + mbTV <- asks (>>= scopeTags) for_ mbTV $ \tv -> atomically $ modifyTVar' tv $ Map.insert key val addSpanEntry key (LogValue val mbTime) = TraceT $ do - mbTV <- asks scopeLogs + mbTV <- asks (>>= scopeLogs) for_ mbTV $ \tv -> do time <- maybe (liftIO getPOSIXTime) pure mbTime atomically $ modifyTVar' tv ((time, key, val) :) @@ -191,5 +192,13 @@ -- 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. +-- +-- See 'runTraceT'' for a variant which allows discarding spans. runTraceT :: TraceT m a -> Tracer -> m a -runTraceT (TraceT reader) tracer = runReaderT reader (Scope tracer Nothing Nothing Nothing) +runTraceT actn tracer = runTraceT' actn (Just tracer) + +-- | Maybe trace an action. If the tracer is 'Nothing', no spans will be published. +runTraceT' :: TraceT m a -> Maybe Tracer -> m a +runTraceT' (TraceT reader) mbTracer = + let scope = fmap (\tracer -> Scope tracer Nothing Nothing Nothing) mbTracer + in runReaderT reader scope diff --git a/src/Control/Monad/Trace/Internal.hs b/src/Control/Monad/Trace/Internal.hs --- a/src/Control/Monad/Trace/Internal.hs +++ b/src/Control/Monad/Trace/Internal.hs @@ -132,7 +132,7 @@ hexDecode :: Text-> Maybe ByteString hexDecode t = case Base16.decode $ BS.Char8.pack $ T.unpack t of - (bs, trail) | BS.null trail -> Just bs + Right bs -> Just bs _ -> Nothing hexEncode :: ByteString -> Text 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 @@ -25,13 +25,13 @@ -- * Cross-process spans -- ** Communication - B3(..), b3ToHeaders, b3FromHeaders, b3ToHeaderValue, b3FromHeaderValue, + B3(..), b3ToHeaders, b3FromHeaders, b3ToHeaderValue, b3FromHeaderValue, b3FromSpan, -- ** Span generation clientSpan, clientSpanWith, serverSpan, serverSpanWith, producerSpanWith, consumerSpanWith, -- * Custom metadata -- ** Tags - tag, addTag, addInheritedTag, + tag, addTag, addInheritedTag, addProducerKind, -- ** Annotations -- | Annotations are similar to tags, but timestamped. annotate, annotateAt, @@ -65,6 +65,7 @@ import Data.Semigroup ((<>)) #endif import Data.Set (Set) +import qualified Data.Set as Set import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T @@ -131,9 +132,10 @@ 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 } + , HTTP.port = maybe 9411 fromIntegral mbPort + , HTTP.requestHeaders = [("content-type", "application/json")] + } void $ let prd = fromMaybe 0 mbPrd in if prd <= 0 then pure Nothing else fmap Just $ forkIO $ forever $ do @@ -167,13 +169,24 @@ -- -- > childSpanWith (addTag "key" "value") "run" $ action -- --- Note that there is not difference with adding the tag after the span. So the above code is +-- Note that there is no 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) } +addTag key val bldr = + bldr { builderTags = Map.insert (publicKeyPrefix <> key) (JSON.toJSON val) (builderTags bldr) } +-- | Adds a producer kind tag to a builder. This is a convenience method to use with 'rootSpanWith', +-- for example: +-- +-- > rootSpanWith addProducerKind alwaysSampled "root" $ action +-- +-- Use this method if you want to create a root producer span. Otherwise use 'producerSpanWith' to +-- create a sub span with producer kind. +addProducerKind :: Builder -> Builder +addProducerKind = addTag kindKey producerKindValue + -- | 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. @@ -221,7 +234,7 @@ b3ToHeaders :: B3 -> Map (CI ByteString) ByteString b3ToHeaders (B3 traceID spanID isSampled isDebug mbParentID) = let - defaultKVs = [(traceIDHeader, encodeTraceID traceID), (spanIDHeader, encodeSpanID spanID)] + defaultKVs = [(traceIDHeader, encodeZipkinTraceID traceID), (spanIDHeader, encodeSpanID spanID)] parentKVs = (parentSpanIDHeader,) . encodeSpanID <$> maybeToList mbParentID sampledKVs = case (isSampled, isDebug) of (_, True) -> [(debugHeader, "1")] @@ -243,7 +256,7 @@ sampled <- findBool dbg sampledHeader guard (not $ sampled == False && dbg) B3 - <$> (find traceIDHeader >>= decodeTraceID) + <$> (find traceIDHeader >>= decodeZipkinTraceID) <*> (find spanIDHeader >>= decodeSpanID) <*> pure sampled <*> pure dbg @@ -258,15 +271,35 @@ (_ , True) -> "d" (True, _) -> "1" (False, _) -> "0" - required = [encodeTraceID traceID, encodeSpanID spanID, state] + required = [encodeZipkinTraceID traceID, encodeSpanID spanID, state] optional = encodeSpanID <$> maybeToList mbParentID in BS.intercalate "-" $ fmap T.encodeUtf8 $ required ++ optional +-- | Prefix used to fill up 128-bit if only a 64-bit trace identifier is given. +shortTraceIDPrefix :: Text +shortTraceIDPrefix = "0000000000000000" + +-- | Decodes a zipkin trace ID from a hex-encoded string, returning nothing if it is invalid. Takes +-- into account that the provided string could be a 16 or 32 lower-hex character trace ID. If the +-- given string consists of 16 lower-hex characters 'shortTraceIDPrefix' is used to fil up the +-- 128-bit trace identifier of 'TraceID'. +decodeZipkinTraceID :: Text -> Maybe TraceID +decodeZipkinTraceID txt = + let normalized = if T.length txt == 16 then shortTraceIDPrefix <> txt else txt + in decodeTraceID normalized + +-- | Hex-encodes a trace ID, providing a 16 or 32 lower-hex character zipkin trace ID. A 16 +-- lower-hex character string is returned if the first 64-bits of the 'TraceID' are zeros. +encodeZipkinTraceID :: TraceID -> Text +encodeZipkinTraceID traceID = + let txt = encodeTraceID traceID + in fromMaybe txt $ T.stripPrefix shortTraceIDPrefix txt + -- | 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 + traceID <- decodeZipkinTraceID traceIDstr spanID <- decodeSpanID spanIDstr let buildB3 = B3 traceID spanID case strs of @@ -304,9 +337,9 @@ else sampledWhen $ b3IsSampled b3 in Endo $ \bldr -> bldr { builderTraceID = Just (b3TraceID b3) - , builderSpanID = Just (b3SpanID b3) , builderSamplingPolicy = Just policy } +-- Prefix added to all user tags. This protects against collisions with internal tags. publicKeyPrefix :: Text publicKeyPrefix = "Z." @@ -318,7 +351,9 @@ kindKey :: Key kindKey = "z.k" --- Internal keys +-- Value that indicates a producer span kind. +producerKindValue :: Text +producerKindValue = "PRODUCER" outgoingSpan :: MonadTrace m => Text -> Endo Builder -> Name -> (Maybe B3 -> m a) -> m a outgoingSpan kind endo name f = childSpanWith (appEndo endo') name actn where @@ -347,11 +382,11 @@ -- | 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) +producerSpanWith f = outgoingSpan producerKindValue (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 "" +incomingSpan :: MonadTrace m => Text -> B3 -> Endo Builder -> m a -> m a +incomingSpan kind b3 endo actn = + let bldr = appEndo (insertTag kindKey kind <> importB3 b3 <> endo) $ builder "" in trace bldr actn -- | Generates a child span with @SERVER@ kind. The client's 'B3' should be provided as input, @@ -359,14 +394,22 @@ 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. +-- | Generates a child span with @SERVER@ kind, optionally modifying the span's builder. This can +-- be useful in combination with 'addEndpoint' if the remote client does not have tracing enabled. +-- The clients's 'B3' should be provided as input. Client and server annotations go on the same +-- span - it means that they share their span ID. serverSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a -serverSpanWith f = incomingSpan "SERVER" (Endo f) +serverSpanWith f b3 = + let endo = Endo $ \bldr -> f $ bldr { builderSpanID = Just (b3SpanID b3) } + in incomingSpan "SERVER" b3 endo --- | Generates a child span with @CONSUMER@ kind. The producer's 'B3' should be provided as input. +-- | Generates a child span with @CONSUMER@ kind, optionally modifying the span's builder. The +-- producer's 'B3' should be provided as input. The generated span will have its parent ID set to +-- the input B3's span ID. consumerSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a -consumerSpanWith f = incomingSpan "CONSUMER" (Endo f) +consumerSpanWith f b3 = + let endo = Endo $ \bldr -> f $ bldr { builderReferences = Set.singleton (ChildOf $ b3SpanID b3) } + in incomingSpan "CONSUMER" b3 endo -- | Information about a hosted service, included in spans and visible in the Zipkin UI. data Endpoint = Endpoint diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -9,11 +9,14 @@ import Monitor.Tracing.Local (collectSpanSamples) import qualified Monitor.Tracing.Zipkin as ZPK +import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad (void) 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 qualified Data.Set as Set import Test.Hspec import Test.Hspec.QuickCheck @@ -37,13 +40,25 @@ pure $ s + r v = runReader (evalStateT actn 1) 2 v `shouldBe` 3 + + it "should be runnable in IO without a tracer" $ do + let + actn :: (MonadIO m, MonadTrace m) => m Int + actn = trace "one" $ do + r <- liftIO $ newIORef 1 + trace "two" $ liftIO (readIORef r) + v <- runTraceT' actn Nothing + v `shouldBe` 1 + 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 @@ -51,12 +66,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 round-trip a B3 using a single header with a 16 lower-hex character TraceId" $ do + let + bs = "64fe8b2a57d3eff7-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" @@ -68,6 +91,16 @@ Just b3 = ZPK.b3FromHeaderValue bs Just b3' = ZPK.b3FromHeaders hdrs b3 `shouldBe` b3' + + it "consumerSpan should use B3 as parent reference" $ do + let + bs = "80f198ee56343ba864fe8b2a57d3eff7-e457b5a2e4d86bd1-1-05e3ac9a4f6e3b90" + Just b3 = ZPK.b3FromHeaderValue bs + [consumerSpan] <- collectSpans $ ZPK.consumerSpanWith id b3 $ pure () + contextTraceID (spanContext consumerSpan) `shouldBe` ZPK.b3TraceID b3 -- same traceId + contextSpanID (spanContext consumerSpan) `shouldNotBe` ZPK.b3SpanID b3 -- different spanId + spanReferences consumerSpan `shouldBe` Set.singleton (ChildOf $ ZPK.b3SpanID b3) -- b3 spanId is parent + describe "collectSpanSamples" $ do it "should collect spans which are still pending after the action returns" $ do spans <- collectSpans $ rootSpan alwaysSampled "sleep-parent" $ do diff --git a/tracing-control.cabal b/tracing-control.cabal --- a/tracing-control.cabal +++ b/tracing-control.cabal @@ -1,7 +1,7 @@ -cabal-version: 1.12 +cabal-version: 2.0 name: tracing-control -version: 0.0.6 +version: 0.0.7.2 synopsis: Distributed tracing description: An OpenTracing-compliant, simple, and extensible distributed tracing library. @@ -38,7 +38,7 @@ build-depends: aeson >= 1.4 , base >= 4.9 && < 5 - , base16-bytestring >= 0.1 + , base16-bytestring >= 1.0 , bytestring >= 0.10 , case-insensitive >= 1.2 , containers >= 0.6 @@ -51,7 +51,7 @@ , stm >= 2.5 , stm-lifted >= 2.5 , text >= 1.2 - , time >= 1.8 + , time >= 1.8 && < 1.10 , transformers >= 0.5 , transformers-base >= 0.4 ghc-options: -Wall