diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index ad7ba88..4de8065 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -2,13 +2,17 @@ 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@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/.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/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/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs index 4368050..218e5da 100644 --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -1,7 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# 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 @@ -9,7 +15,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 @@ -29,11 +35,19 @@ import Control.Monad.Trace.Class import Control.Monad.Trace.Internal import Control.Applicative ((<|>)) +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) +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(..), 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) @@ -41,9 +55,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 @@ -102,13 +113,27 @@ 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 ) 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 +-- 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 (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 (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 $ ask >>= \case Nothing -> reader Just parentScope -> do @@ -116,8 +141,8 @@ instance MonadUnliftIO m => MonadTrace (TraceT m) where mbParentSpn = scopeSpan parentScope mbParentCtx = spanContext <$> mbParentSpn mbTraceID = contextTraceID <$> mbParentCtx - spanID <- maybe (liftIO randomSpanID) pure $ builderSpanID bldr - traceID <- maybe (liftIO randomTraceID) pure $ builderTraceID bldr <|> mbTraceID + 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) @@ -132,13 +157,12 @@ instance MonadUnliftIO m => MonadTrace (TraceT m) where 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 + local (const $ Just $ Scope tracer (Just spn) (Just tagsTV) (Just logsTV)) reader cleanup = do end <- liftIO $ getPOSIXTime atomically $ readTVar startTV >>= \case @@ -162,9 +186,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-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 139ba7f..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: nightly-2021-04-02 +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 8be4a66..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: 576534 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/4/2.yaml - sha256: 76ba2ea759dfc59a1b2a9ea92ea2c8d418812bc57612522ce17955e19d817faa - original: nightly-2021-04-02 diff --git a/test/Spec.hs b/test/Spec.hs index 18b0681..1ec1206 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -13,16 +13,19 @@ 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 -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 +105,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-control.cabal similarity index 64% rename from tracing.cabal rename to tracing-control.cabal index dd2a2fe..173f7c3 100644 --- a/tracing.cabal +++ b/tracing-control.cabal @@ -1,17 +1,21 @@ cabal-version: 2.0 -name: tracing -version: 0.0.7.2 +name: tracing-control +version: 0.0.7.3 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 @@ -39,14 +43,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 + , time >= 1.8 && < 1.13 , transformers >= 0.5 - , unliftio >= 0.2 + , transformers-base >= 0.4 ghc-options: -Wall default-language: Haskell2010 @@ -58,10 +65,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 + , tracing-control ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010