tracing 0.0.3.0 → 0.0.4.0

raw patch · 7 files changed

+68/−71 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +2/−2
• app/ZipkinExample.hs +0/−27
• src/Control/Monad/Trace.hs +2/−3
• src/Monitor/Tracing/Local.hs +6/−1
• src/Monitor/Tracing/Zipkin.hs +44/−20
• test/Spec.hs +13/−3
• tracing.cabal +1/−15

@@ -13,11 +13,11 @@  -- A traced action with its root span and two children. run :: MonadTrace m => m ()-run = rootSpan alwaysSampled "root" $ do+run = rootSpan alwaysSampled "parent" $ do   childSpan "child-a" runA   childSpan "child-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.+or take a look at examples in the `examples/` folder.

@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | A simple tracing example which publishes traces to a local Zipkin server.-module Main where--import Control.Monad (void)-import Control.Monad.Trace.Class (rootSpanWith)-import Monitor.Tracing-import qualified Monitor.Tracing.Zipkin as ZPK-import UnliftIO (MonadUnliftIO, liftIO)-import UnliftIO.Concurrent (forkIO, threadDelay)--example :: (MonadTrace m, MonadUnliftIO m) => m ()-example = rootSpanWith (ZPK.addInheritedTag "id" "1234") alwaysSampled "something" $ do-  ZPK.tag "tag.key1" "a tag value"-  threadDelay 100000-  childSpan "nested1" $ do-    void $ forkIO $ childSpan "concurrent" $ do-      threadDelay 20000-      ZPK.tag "tag.key2" "another tag value"-    ZPK.annotate "launched concurrent"-    threadDelay 10000-  ZPK.annotate "nested1 ended"-  childSpan "nested2" $ threadDelay 30000--main :: IO ()-main = ZPK.with ZPK.defaultSettings $ ZPK.run example

@@ -128,15 +128,14 @@       then do         tagsTV <- newTVarIO $ builderTags bldr         logsTV <- newTVarIO []-        startTV <- newTVarIO Nothing -- To detect whether an exception happened.+        startTV <- newTVarIO Nothing -- To detect whether an exception happened during span setup.         let-          childScope = Scope tracer (Just spn) (Just tagsTV) (Just logsTV)           run = do             start <- liftIO $ getPOSIXTime             atomically $ do               writeTVar startTV (Just start)               modifyTVar' (tracerPendingCount tracer) (+1)-            local (const childScope) reader+            local (const $ Scope tracer (Just spn) (Just tagsTV) (Just logsTV)) reader           cleanup = do             end <- liftIO $ getPOSIXTime             atomically $ readTVar startTV >>= \case

@@ -16,7 +16,12 @@ -- -- Spans which start before the action returns are guaranteed to be collected, even if they complete -- after (in this case collection will block until their completion). More precisely,--- 'collectSamples' will return the first time there are no pending spans after the action is done.+-- 'collectSpanSamples' will return the first time there are no pending spans after the action is+-- done. For example:+--+-- > collectSpanSamples $ rootSpan alwaysSampled "parent" $ do+-- >   forkIO $ childSpan "child" $ threadDelay 2000000 -- Asynchronous 2 second child span.+-- >   threadDelay 1000000 -- Returns after one second, but the child span will still be sampled. collectSpanSamples :: MonadUnliftIO m => TraceT m a -> m (a, [Sample]) collectSpanSamples actn = do   tracer <- newTracer

@@ -6,6 +6,10 @@  -- | This module implements a <https://zipkin.apache.org/ Zipkin>-powered trace publisher. You will -- almost certainly want to import it qualified.+--+-- Zipkin does not support all OpenTracing functionality. To guarantee that everything works as+-- expected, you should only use the functions defined in this module or exported by+-- "Monitor.Tracing". module Monitor.Tracing.Zipkin (   -- * Configuration   -- ** General settings@@ -21,14 +25,16 @@   -- ** Communication   B3(..), b3ToHeaders, b3FromHeaders, b3ToHeaderValue, b3FromHeaderValue,   -- ** Span generation-  clientSpan, serverSpan, producerSpan, consumerSpan,+  clientSpan, clientSpanWith, serverSpan, serverSpanWith, producerSpanWith, consumerSpanWith,    -- * Custom metadata   -- ** Tags   tag, addTag, addInheritedTag,   -- ** Annotations   -- | Annotations are similar to tags, but timestamped.-  annotate, annotateAt+  annotate, annotateAt,+  -- ** Endpoints+  addEndpoint ) where  import Control.Monad.Trace@@ -165,7 +171,7 @@  -- | Adds an inherited tag to a builder. Unlike a tag added via 'addTag', this tag: ----- * will be inherited by all the span's children.+-- * will be inherited by all the span's /local/ children. -- * can only be added at span construction time. -- -- For example, to add an ID tag to all spans inside a trace:@@ -309,9 +315,9 @@  -- Internal keys -outgoingSpan :: MonadTrace m => Text -> Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a-outgoingSpan kind mbEpt name f = childSpanWith (appEndo endo) name actn where-  endo = insertTag kindKey kind <> maybe mempty (insertTag endpointKey) mbEpt+outgoingSpan :: MonadTrace m => Text -> Endo Builder -> Name -> (Maybe B3 -> m a) -> m a+outgoingSpan kind endo name f = childSpanWith (appEndo endo') name actn where+  endo' = insertTag kindKey kind <> endo   actn = activeSpan >>= \case     Nothing -> f Nothing     Just spn -> f $ Just $ b3FromSpan spn@@ -320,32 +326,42 @@ -- (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: --+-- > import Network.HTTP.Simple+-- > -- > clientSpan "api-call" $ \(Just b3) -> $ do--- >   res <- httpLbs "http://host/api" { requestHeaders = b3ToHeaders b3 }+-- >   res <- httpBS "http://host/api" & addRequestHeader "b3" (b3ToHeaderValue b3) -- >   process res -- Do something with the response.-clientSpan :: MonadTrace m => Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a-clientSpan = outgoingSpan "CLIENT"+clientSpan :: MonadTrace m => Name -> (Maybe B3 -> m a) -> m a+clientSpan = clientSpanWith id +-- | Generates a client span, optionally modifying the span's builder. This can be useful in+-- combination with 'addEndpoint' if the remote server does not have tracing enabled.+clientSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> (Maybe B3 -> m a) -> m a+clientSpanWith f = outgoingSpan "CLIENT" (Endo f)+ -- | Generates a child span with @PRODUCER@ kind. This function also provides the corresponding 'B3' -- so that it can be forwarded to the consumer.-producerSpan :: MonadTrace m => Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a-producerSpan = outgoingSpan "PRODUCER"+producerSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> (Maybe B3 -> m a) -> m a+producerSpanWith f = outgoingSpan "PRODUCER" (Endo f) -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 ""+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 ""   in trace bldr actn  -- | Generates a child span with @SERVER@ kind. The client's 'B3' should be provided as input, -- for example parsed using 'b3FromHeaders'.-serverSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a-serverSpan = incomingSpan "SERVER"+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.+serverSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a+serverSpanWith f = incomingSpan "SERVER" (Endo f)+ -- | Generates a child span with @CONSUMER@ kind. The producer's 'B3' should be provided as input.-consumerSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a-consumerSpan = incomingSpan "CONSUMER"+consumerSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a+consumerSpanWith f = incomingSpan "CONSUMER" (Endo f)  -- | Information about a hosted service, included in spans and visible in the Zipkin UI. data Endpoint = Endpoint@@ -362,6 +378,14 @@ -- | An empty endpoint. defaultEndpoint :: Endpoint defaultEndpoint = Endpoint Nothing Nothing Nothing Nothing++-- | Adds a remote endpoint to a builder. This is mostly useful when generating cross-process spans+-- where the remote endpoint is not already traced (otherwise Zipkin will associate the spans+-- correctly automatically). For example when emitting a request to an outside server:+--+-- > clientSpanWith (addEndpoint "outside-api") -- ...+addEndpoint :: Endpoint -> Builder -> Builder+addEndpoint = appEndo . insertTag endpointKey  -- | Generates an endpoint with the given string as service. instance IsString Endpoint where

@@ -9,13 +9,16 @@ import Monitor.Tracing.Local (collectSpanSamples) import qualified Monitor.Tracing.Zipkin as ZPK +import Control.Monad (void) import Control.Monad.Reader (MonadReader, Reader, ReaderT, ask, runReader, runReaderT) import Control.Monad.State.Strict (MonadState, StateT, evalStateT, get) import qualified Data.Map.Strict as Map import Data.Text (Text) import Test.Hspec import Test.Hspec.QuickCheck-import UnliftIO (MonadUnliftIO)+import UnliftIO+import UnliftIO.Concurrent+import UnliftIO.STM  collectSpans :: MonadUnliftIO m => TraceT m () -> m [Span] collectSpans actn = fmap sampleSpan . snd <$> collectSpanSamples actn@@ -34,10 +37,10 @@       v `shouldBe` 3   describe "trace" $ do     it "should not create spans when no traces are started" $ do-      spans <- collectSpans @IO (pure ())+      spans <- collectSpans $ pure ()       fmap spanName spans `shouldBe` []     it "should collect a single span when no children are created" $ do-      spans <- collectSpans @IO (trace "t" { builderSamplingPolicy = Just alwaysSampled } $ pure ())+      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@@ -63,3 +66,10 @@         Just b3 = ZPK.b3FromHeaderValue bs         Just b3' = ZPK.b3FromHeaders hdrs       b3 `shouldBe` b3'+  describe "collectSpanSamples" $ do+    it "should collect spans which are still pending after the action returns" $ do+      spans <- collectSpans $ rootSpan alwaysSampled "sleep-parent" $ do+        tmv <- newEmptyTMVarIO+        void $ forkIO $ childSpan "sleep-child" $ atomically (putTMVar tmv ()) >> threadDelay 20000+        void $ atomically $ readTMVar tmv+      fmap spanName spans `shouldMatchList` ["sleep-parent", "sleep-child"]

@@ -1,5 +1,5 @@ name:                tracing-version:             0.0.3.0+version:             0.0.4.0 synopsis:            Distributed tracing description:         An OpenTracing-compliant, simple, and extensible distributed tracing library. homepage:            https://github.com/mtth/tracing@@ -49,20 +49,6 @@                      , containers >= 0.6                      , hspec >=2.6                      , mtl >= 2.2-                     , stm >= 2.5-                     , text >= 1.2-                     , tracing-                     , unliftio >= 0.2-  default-language:    Haskell2010--executable zipkin-example-  hs-source-dirs:      app-  main-is:             ZipkinExample.hs-  build-depends:       aeson >= 1.4-                     , base >=4.8 && <5-                     , bytestring >= 0.10-                     , containers >= 0.6-                     , ip >= 1.4                      , stm >= 2.5                      , text >= 1.2                      , tracing