From 3b45732803614fc96689bde8fc95b9fd7f7a3dc4 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 22 Jun 2020 15:36:11 +0200 Subject: [PATCH 01/12] Derive more --- src/Control/Monad/Trace.hs | 9 ++++++++- tracing.cabal | 4 +++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs index 4368050..6033259 100644 --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -29,10 +29,15 @@ import Control.Monad.Trace.Class import Control.Monad.Trace.Internal import Control.Applicative ((<|>)) +import Control.Monad.Base (MonadBase) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT(ReaderT), ask, asks, local, runReaderT) import Control.Monad.Reader.Class (MonadReader) +import Control.Monad.Error.Class (MonadError) +import Control.Monad.State.Class (MonadState) import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Writer.Class (MonadWriter) import qualified Data.Aeson as JSON import Data.Foldable (for_) import Data.List (sortOn) @@ -102,7 +107,9 @@ data Scope = Scope -- | A span generation monad. newtype TraceT m a = TraceT { traceTReader :: ReaderT (Maybe Scope) m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) + deriving ( Functor, Applicative, Monad, MonadTrans + , MonadWriter w, MonadState s, MonadError e + , MonadIO, MonadBase b, MonadBaseControl b ) instance MonadReader r m => MonadReader r (TraceT m) where ask = lift ask diff --git a/tracing.cabal b/tracing.cabal index dd2a2fe..cca569f 100644 --- a/tracing.cabal +++ b/tracing.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: tracing -version: 0.0.7.2 +version: 0.0.5.2 synopsis: Distributed tracing description: An OpenTracing-compliant, simple, and extensible distributed tracing library. @@ -39,6 +39,7 @@ library , case-insensitive >= 1.2 , containers >= 0.6 , http-client >= 0.5 + , monad-control >= 1.0 , mtl >= 2.2 , network >= 2.8 , random >= 1.1 @@ -46,6 +47,7 @@ library , text >= 1.2 , time >= 1.8 && < 1.10 , transformers >= 0.5 + , transformers-base >= 0.4 , unliftio >= 0.2 ghc-options: -Wall default-language: Haskell2010 From 809ccfa108a5203d0bcbcb10a20b1c9cc6c7b870 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 22 Jun 2020 16:06:01 +0200 Subject: [PATCH 02/12] Use monad-control --- src/Control/Monad/Trace.hs | 96 ++++++++++++++++------------------- src/Monitor/Tracing/Local.hs | 8 +-- src/Monitor/Tracing/Zipkin.hs | 8 +-- stack.yaml | 3 +- tracing.cabal | 3 +- 5 files changed, 59 insertions(+), 59 deletions(-) diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs index 6033259..91ee382 100644 --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -29,7 +29,9 @@ import Control.Monad.Trace.Class import Control.Monad.Trace.Internal import Control.Applicative ((<|>)) -import Control.Monad.Base (MonadBase) +import Control.Concurrent.STM.Lifted (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar) +import Control.Exception.Lifted (finally) +import Control.Monad.Base (MonadBase, liftBase) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT(ReaderT), ask, asks, local, runReaderT) import Control.Monad.Reader.Class (MonadReader) @@ -46,9 +48,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Time.Clock (NominalDiffTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import UnliftIO (MonadUnliftIO, withRunInIO) -import UnliftIO.Exception (finally) -import UnliftIO.STM (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar) -- | A collection of span tags. type Tags = Map Key JSON.Value @@ -115,50 +114,48 @@ instance MonadReader r m => MonadReader r (TraceT m) where ask = lift ask local f (TraceT (ReaderT g)) = TraceT $ ReaderT $ \r -> local f $ g r -instance MonadUnliftIO m => MonadTrace (TraceT m) where - trace bldr (TraceT reader) = TraceT $ ask >>= \case - Nothing -> reader - Just parentScope -> do - let - mbParentSpn = scopeSpan parentScope - mbParentCtx = spanContext <$> mbParentSpn - mbTraceID = contextTraceID <$> mbParentCtx - spanID <- maybe (liftIO randomSpanID) pure $ builderSpanID bldr - traceID <- maybe (liftIO 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 - scope = 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 $ Just scope) 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) +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 + + activeSpan = TraceT $ asks scopeSpan addSpanEntry key (TagValue val) = TraceT $ do mbTV <- asks (>>= scopeTags) @@ -169,9 +166,6 @@ instance MonadUnliftIO m => MonadTrace (TraceT m) where time <- maybe (liftIO getPOSIXTime) pure mbTime atomically $ modifyTVar' tv ((time, key, val) :) -instance MonadUnliftIO m => MonadUnliftIO (TraceT m) where - withRunInIO inner = TraceT $ withRunInIO $ \run -> inner (run . traceTReader) - -- | Trace an action, sampling its generated spans. This method is thread-safe and can be used to -- trace multiple actions concurrently. -- diff --git a/src/Monitor/Tracing/Local.hs b/src/Monitor/Tracing/Local.hs index e980ae5..4255eee 100644 --- a/src/Monitor/Tracing/Local.hs +++ b/src/Monitor/Tracing/Local.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} -- | This module provides convenience functionality to debug traces locally. For production use, -- prefer alternatives, e.g. "Monitor.Tracing.Zipkin". module Monitor.Tracing.Local ( @@ -6,10 +7,10 @@ module Monitor.Tracing.Local ( import Control.Concurrent.STM (atomically, readTVar, readTChan, tryReadTChan) import Control.Monad.Fix (fix) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trace +import Control.Monad.Trans.Control (MonadBaseControl) import Data.IORef (modifyIORef', newIORef, readIORef) -import UnliftIO (MonadUnliftIO) -- | Runs a 'TraceT' action, returning any collected samples alongside its output. The samples are -- sorted chronologically by completion time (e.g. the head is the first span to complete). @@ -22,7 +23,8 @@ import UnliftIO (MonadUnliftIO) -- > 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 :: (MonadIO m, MonadBaseControl IO m) + => TraceT m a -> m (a, [Sample]) collectSpanSamples actn = do tracer <- newTracer rv <- runTraceT actn tracer diff --git a/src/Monitor/Tracing/Zipkin.hs b/src/Monitor/Tracing/Zipkin.hs index 60828a8..b89ff67 100644 --- a/src/Monitor/Tracing/Zipkin.hs +++ b/src/Monitor/Tracing/Zipkin.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -43,9 +44,11 @@ import Control.Monad.Trace.Class import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM (atomically, tryReadTChan) +import Control.Exception.Lifted (finally) import Control.Monad (forever, guard, void, when) import Control.Monad.Fix (fix) import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Aeson as JSON import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS @@ -71,8 +74,6 @@ import Data.Time.Clock.POSIX (POSIXTime) import Network.HTTP.Client (Manager, Request) import qualified Network.HTTP.Client as HTTP import Network.Socket (HostName, PortNumber) -import UnliftIO (MonadUnliftIO) -import UnliftIO.Exception (finally) -- | 'Zipkin' creation settings. data Settings = Settings @@ -154,7 +155,8 @@ publish z = liftIO $ flushSpans (zipkinEndpoint z) (zipkinTracer z) (zipkinRequest z) (zipkinManager z) -- | Convenience method to start a 'Zipkin', run an action, and publish all spans before returning. -with :: MonadUnliftIO m => Settings -> (Zipkin -> m a) -> m a +with :: (MonadIO m, MonadBaseControl IO m) + => Settings -> (Zipkin -> m a) -> m a with settings f = do zipkin <- new settings f zipkin `finally` publish zipkin diff --git a/stack.yaml b/stack.yaml index 139ba7f..087592d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -37,7 +37,8 @@ packages: # Dependency packages to be pulled from upstream that are not in the resolver # using the same syntax as the packages field. # (e.g., acme-missiles-0.3) -# extra-deps: [] +extra-deps: +- stm-lifted-2.5.0.0 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/tracing.cabal b/tracing.cabal index cca569f..6f370e1 100644 --- a/tracing.cabal +++ b/tracing.cabal @@ -39,16 +39,17 @@ library , case-insensitive >= 1.2 , containers >= 0.6 , http-client >= 0.5 + , lifted-base >= 0.2 , monad-control >= 1.0 , mtl >= 2.2 , network >= 2.8 , random >= 1.1 , stm >= 2.5 + , stm-lifted >= 2.5 , text >= 1.2 , time >= 1.8 && < 1.10 , transformers >= 0.5 , transformers-base >= 0.4 - , unliftio >= 0.2 ghc-options: -Wall default-language: Haskell2010 From 776cc0637791c05f87910442d4f47105d99b7f2b Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 22 Jun 2020 16:58:27 +0200 Subject: [PATCH 03/12] Fix tests --- test/Spec.hs | 12 +++++++----- tracing.cabal | 4 +++- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 18b0681..a7bd2a0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -18,11 +18,13 @@ import Data.Text (Text) import qualified Data.Set as Set import Test.Hspec import Test.Hspec.QuickCheck -import UnliftIO -import UnliftIO.Concurrent -import UnliftIO.STM -collectSpans :: MonadUnliftIO m => TraceT m () -> m [Span] +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Concurrent.Lifted +import Control.Concurrent.STM.Lifted + +collectSpans :: (MonadIO m, MonadBaseControl IO m) => TraceT m () -> m [Span] collectSpans actn = fmap sampleSpan . snd <$> collectSpanSamples actn main :: IO () @@ -102,6 +104,6 @@ main = hspec $ 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 $ fork $ childSpan "sleep-child" $ atomically (putTMVar tmv ()) >> threadDelay 20000 void $ atomically $ readTMVar tmv fmap spanName spans `shouldMatchList` ["sleep-parent", "sleep-child"] diff --git a/tracing.cabal b/tracing.cabal index 6f370e1..8e291d5 100644 --- a/tracing.cabal +++ b/tracing.cabal @@ -61,10 +61,12 @@ test-suite tracing-test base , containers , hspec >=2.6 + , lifted-base >= 0.2 + , monad-control >= 1.0 , mtl , stm + , stm-lifted >= 2.5 , text , tracing - , unliftio ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 From 29e604dcab100c31d7408441ce3b856ed7eb01a0 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 22 Jun 2020 18:25:27 +0200 Subject: [PATCH 04/12] Fix compilation on 8.0 --- src/Control/Monad/Trace.hs | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs index 91ee382..2702ea1 100644 --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -1,7 +1,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- For the MonadBaseControl instance. {-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance. -- | This module is useful mostly for tracing backend implementors. If you are only interested in @@ -38,9 +43,10 @@ import Control.Monad.Reader.Class (MonadReader) import Control.Monad.Error.Class (MonadError) import Control.Monad.State.Class (MonadState) import Control.Monad.Trans.Class (MonadTrans, lift) -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Control (MonadBaseControl(..), RunInBase) import Control.Monad.Writer.Class (MonadWriter) import qualified Data.Aeson as JSON +import Data.Coerce import Data.Foldable (for_) import Data.List (sortOn) import Data.Map.Strict (Map) @@ -108,12 +114,24 @@ data Scope = Scope 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, MonadBaseControl b ) + , MonadIO, MonadBase b ) instance MonadReader r m => MonadReader r (TraceT m) where ask = lift ask local f (TraceT (ReaderT g)) = TraceT $ ReaderT $ \r -> local f $ g r +-- Cannot be derived in GHC 8.0 due to type family. +instance MonadBaseControl b m => MonadBaseControl b (TraceT m) where + 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) + liftBaseWith + restoreM :: forall a. StM (TraceT m) a -> TraceT m a + restoreM + = coerce @(StM (ReaderT Scope m) a -> ReaderT Scope m a) + restoreM + instance (MonadIO m, MonadBaseControl IO m) => MonadTrace (TraceT m) where trace bldr (TraceT reader) = TraceT $ do parentScope <- ask From a6b811cccec121e4e2d3afad8c733ab4ae0ea0dc Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Tue, 14 Jul 2020 11:18:14 +0200 Subject: [PATCH 05/12] Prepare to release as 'tracing-control' --- .gitignore | 2 ++ src/Control/Monad/Trace.hs | 2 +- tracing.cabal => tracing-control.cabal | 18 +++++++++++------- 3 files changed, 14 insertions(+), 8 deletions(-) create mode 100644 .gitignore rename tracing.cabal => tracing-control.cabal (75%) diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..58c1ec9 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.stack* +stack.yaml.lock diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs index 2702ea1..4701b55 100644 --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -14,7 +14,7 @@ module Control.Monad.Trace ( -- * Tracers Tracer, newTracer, - runTraceT, runTraceT', TraceT, + runTraceT, runTraceT', TraceT(..), -- * Collected data -- | Tracers currently expose two pieces of data: completed spans and pending span count. Note diff --git a/tracing.cabal b/tracing-control.cabal similarity index 75% rename from tracing.cabal rename to tracing-control.cabal index 8e291d5..cbad5dc 100644 --- a/tracing.cabal +++ b/tracing-control.cabal @@ -1,17 +1,21 @@ cabal-version: 2.0 -name: tracing -version: 0.0.5.2 +name: tracing-control +version: 0.0.6 synopsis: Distributed tracing description: An OpenTracing-compliant, simple, and extensible distributed tracing library. + This is a fork of which + switches from to + . + category: Web -homepage: https://github.com/mtth/tracing +homepage: https://github.com/serras/tracing license: BSD3 license-file: LICENSE -author: Matthieu Monsch -maintainer: mtth@apache.org +author: Matthieu Monsch, Alejandro Serrano +maintainer: alejandro.serrano@47deg.com copyright: 2020 Matthieu Monsch build-type: Simple @@ -19,7 +23,7 @@ extra-source-files: README.md source-repository head type: git - location: https://github.com/mtth/tracing + location: https://github.com/serras/tracing library hs-source-dirs: src @@ -67,6 +71,6 @@ test-suite tracing-test , stm , stm-lifted >= 2.5 , text - , tracing + , tracing-control ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 From 0353f8de33f2463f584ed0104cd20ba77eef9a97 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Tue, 14 Jul 2020 11:19:03 +0200 Subject: [PATCH 06/12] Fix from https://github.com/mtth/tracing/pull/1 --- src/Monitor/Tracing/Zipkin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Monitor/Tracing/Zipkin.hs b/src/Monitor/Tracing/Zipkin.hs index b89ff67..b96ce47 100644 --- a/src/Monitor/Tracing/Zipkin.hs +++ b/src/Monitor/Tracing/Zipkin.hs @@ -132,6 +132,7 @@ new (Settings mbHostname mbPort mbEpt mbMgr mbPrd) = liftIO $ do 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.requestHeaders = [("content-type", "application/json")] From 4f7f482bf9f822398d0d64924ce81aed9c2f3395 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Tue, 14 Jul 2020 11:23:14 +0200 Subject: [PATCH 07/12] More preparations for release --- README.md | 4 +++- tracing-control.cabal | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 68beb2e..0cd80fd 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,6 @@ -# Tracing [![Stackage LTS](https://stackage.org/package/tracing/badge/lts)](https://stackage.org/lts/package/tracing) [![Stackage Nightly](https://stackage.org/package/tracing/badge/nightly)](https://stackage.org/nightly/package/tracing) [![Hackage](https://img.shields.io/hackage/v/tracing.svg)](https://hackage.haskell.org/package/tracing) [![Build Status](https://travis-ci.org/mtth/tracing.svg?branch=master)](https://travis-ci.org/mtth/tracing) +# Tracing [![Hackage](https://img.shields.io/hackage/v/tracing-control.svg)](https://hackage.haskell.org/package/tracing-control) + +**Important note**: this is a fork of the original [tracing](https://github.com/mtth/tracing) library in which `unliftio` has been replaced by `monad-control`. An [OpenTracing](https://opentracing.io/)-compliant, simple, and extensible distributed tracing library. diff --git a/tracing-control.cabal b/tracing-control.cabal index cbad5dc..e4d5fea 100644 --- a/tracing-control.cabal +++ b/tracing-control.cabal @@ -7,7 +7,7 @@ description: An OpenTracing-compliant, simple, and extensible distributed tracing library. This is a fork of which - switches from to + switches from to . category: Web From 174fc92bfea0cd99516e6a6d15dda989566c9cb6 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 18 Nov 2021 15:14:00 +0100 Subject: [PATCH 08/12] Update to base16-bytestring --- stack.yaml | 5 ++--- tracing-control.cabal | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/stack.yaml b/stack.yaml index 087592d..656e1a7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: nightly-2021-04-02 +resolver: lts-18.17 # User packages to be built. # Various formats can be used as shown in the example below. @@ -37,8 +37,7 @@ packages: # Dependency packages to be pulled from upstream that are not in the resolver # using the same syntax as the packages field. # (e.g., acme-missiles-0.3) -extra-deps: -- stm-lifted-2.5.0.0 +# extra-deps: [] # Override default flag values for local packages and extra-deps # flags: {} diff --git a/tracing-control.cabal b/tracing-control.cabal index e4d5fea..9491fba 100644 --- a/tracing-control.cabal +++ b/tracing-control.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: tracing-control -version: 0.0.6 +version: 0.0.7 synopsis: Distributed tracing description: An OpenTracing-compliant, simple, and extensible distributed tracing library. From 9fb1d26240924a16d7e05f02f8bcd0af5f94ba35 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 18 Nov 2021 15:29:08 +0100 Subject: [PATCH 09/12] Fixes for merge --- src/Control/Monad/Trace.hs | 87 ++++++++++++++++++----------------- src/Monitor/Tracing/Zipkin.hs | 1 - stack.yaml.lock | 8 ++-- tracing-control.cabal | 2 +- 4 files changed, 49 insertions(+), 49 deletions(-) diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs index 4701b55..6ed28dc 100644 --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -125,55 +125,56 @@ instance MonadBaseControl b m => MonadBaseControl b (TraceT m) where 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 - - activeSpan = TraceT $ asks scopeSpan + 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) addSpanEntry key (TagValue val) = TraceT $ do mbTV <- asks (>>= scopeTags) diff --git a/src/Monitor/Tracing/Zipkin.hs b/src/Monitor/Tracing/Zipkin.hs index b96ce47..b89ff67 100644 --- a/src/Monitor/Tracing/Zipkin.hs +++ b/src/Monitor/Tracing/Zipkin.hs @@ -132,7 +132,6 @@ new (Settings mbHostname mbPort mbEpt mbMgr mbPrd) = liftIO $ do 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.requestHeaders = [("content-type", "application/json")] diff --git a/stack.yaml.lock b/stack.yaml.lock index 8be4a66..1057719 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 576534 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/4/2.yaml - sha256: 76ba2ea759dfc59a1b2a9ea92ea2c8d418812bc57612522ce17955e19d817faa - original: nightly-2021-04-02 + size: 586292 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/17.yaml + sha256: e66e70a7f998036025e8f40abc89b8eeb79c88f57727020cba1b54f375aa7ca0 + original: lts-18.17 diff --git a/tracing-control.cabal b/tracing-control.cabal index 9491fba..df907b3 100644 --- a/tracing-control.cabal +++ b/tracing-control.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: tracing-control -version: 0.0.7 +version: 0.0.7.2 synopsis: Distributed tracing description: An OpenTracing-compliant, simple, and extensible distributed tracing library. From ca5d4a5ebada2fde89a274ebf47a25693aebdb99 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 18 Nov 2021 15:40:48 +0100 Subject: [PATCH 10/12] Fix tests --- test/Spec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Spec.hs b/test/Spec.hs index a7bd2a0..1ec1206 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -13,6 +13,7 @@ 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 From 5b9e5c93266b97bb3cd95cc2b6a54eb578444d9b Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Sun, 20 Mar 2022 19:35:20 +0100 Subject: [PATCH 11/12] Updates for 9.2 --- .github/workflows/test.yml | 11 ++++--- src/Control/Monad/Trace.hs | 1 + stack-nightly.yaml | 64 ++++++++++++++++++++++++++++++++++++++ stack.yaml | 2 +- stack.yaml.lock | 12 ------- tracing-control.cabal | 4 +-- 6 files changed, 75 insertions(+), 19 deletions(-) create mode 100644 stack-nightly.yaml delete mode 100644 stack.yaml.lock diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index ad7ba88..fe5b8fa 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -3,12 +3,15 @@ on: [push] jobs: test: runs-on: ubuntu-latest + strategy: + matrix: + ghc: ['9.2', '9.0', '8.10', '8.8'] steps: - - uses: actions/checkout@v1 - - uses: actions/setup-haskell@v1 + - uses: actions/checkout@v2 + - uses: haskell/actions/setup@v1 with: - ghc-version: '8.6.5' - cabal-version: '3.0' + ghc-version: ${{ matrix.ghc }} + cabal-version: 'latest' - name: Install dependencies run: | cabal update diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs index 6ed28dc..218e5da 100644 --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE InstanceSigs #-} diff --git a/stack-nightly.yaml b/stack-nightly.yaml new file mode 100644 index 0000000..911ffca --- /dev/null +++ b/stack-nightly.yaml @@ -0,0 +1,64 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: nightly-2022-03-20 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# using the same syntax as the packages field. +# (e.g., acme-missiles-0.3) +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.9" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml b/stack.yaml index 656e1a7..f4d5c5a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-18.17 +resolver: lts-19.0 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index 1057719..0000000 --- a/stack.yaml.lock +++ /dev/null @@ -1,12 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: [] -snapshots: -- completed: - size: 586292 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/17.yaml - sha256: e66e70a7f998036025e8f40abc89b8eeb79c88f57727020cba1b54f375aa7ca0 - original: lts-18.17 diff --git a/tracing-control.cabal b/tracing-control.cabal index df907b3..173f7c3 100644 --- a/tracing-control.cabal +++ b/tracing-control.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: tracing-control -version: 0.0.7.2 +version: 0.0.7.3 synopsis: Distributed tracing description: An OpenTracing-compliant, simple, and extensible distributed tracing library. @@ -51,7 +51,7 @@ library , stm >= 2.5 , stm-lifted >= 2.5 , text >= 1.2 - , time >= 1.8 && < 1.10 + , time >= 1.8 && < 1.13 , transformers >= 0.5 , transformers-base >= 0.4 ghc-options: -Wall From df9a0836254a2b0eb6d4409383c79fa1c0270cfa Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Sun, 20 Mar 2022 19:37:06 +0100 Subject: [PATCH 12/12] Also test on Windows --- .github/workflows/test.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index fe5b8fa..4de8065 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -2,10 +2,11 @@ name: Haskell CI on: [push] jobs: test: - runs-on: ubuntu-latest + runs-on: ${{ matrix.os }} strategy: matrix: ghc: ['9.2', '9.0', '8.10', '8.8'] + os: [ubuntu-latest, windows-latest] steps: - uses: actions/checkout@v2 - uses: haskell/actions/setup@v1