tracing-control 0.0.6 → 0.0.7.2
raw patch · 5 files changed
+158/−73 lines, 5 filesdep ~base16-bytestringdep ~time
Dependency ranges changed: base16-bytestring, time
Files
- src/Control/Monad/Trace.hs +56/−47
- src/Control/Monad/Trace/Internal.hs +1/−1
- src/Monitor/Tracing/Zipkin.hs +64/−21
- test/Spec.hs +33/−0
- tracing-control.cabal +4/−4
src/Control/Monad/Trace.hs view
@@ -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
src/Control/Monad/Trace/Internal.hs view
@@ -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
src/Monitor/Tracing/Zipkin.hs view
@@ -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
test/Spec.hs view
@@ -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
tracing-control.cabal view
@@ -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