diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs index aa24bbe..bb3dd0e 100644 --- a/src/Control/Monad/Trace.hs +++ b/src/Control/Monad/Trace.hs @@ -41,15 +41,14 @@ import Control.Monad.Trace.Class import Control.Monad.Trace.Internal import Control.Applicative ((<|>)) -import Control.Monad.STM (retry) -import Control.Concurrent.STM.Lifted +import Control.Concurrent.STM (STM, TVar, retry, atomically, readTVar, writeTVar, modifyTVar, modifyTVar', newTVarIO) import Control.Exception.Lifted import Control.Monad (when) 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.Trans.Class (MonadTrans, lift) -import Control.Monad.Base (MonadBase) +import Control.Monad.Base (MonadBase, liftBase) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Trans.Control import Control.Monad.Except (MonadError) @@ -195,10 +194,10 @@ instance (MonadBaseControl IO m, MonadIO 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 + Just policy -> liftBase policy Nothing -> pure $ fromMaybe Never (spanSamplingDecision <$> mbParentSpn) let baggages = fromMaybe Map.empty $ contextBaggages <$> mbParentCtx @@ -207,20 +206,20 @@ instance (MonadBaseControl IO m, MonadIO m) => MonadTrace (TraceT m) where 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. + tagsTV <- liftBase . newTVarIO $ builderTags bldr + logsTV <- liftBase $ newTVarIO [] + startTV <- liftBase $ 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 + start <- liftBase getPOSIXTime + liftBase . atomically $ do writeTVar startTV (Just start) modifyTVar' (tracerPendingCount tracer) (+1) local (const $ Just scope) reader cleanup = do - end <- liftIO $ getPOSIXTime - atomically $ readTVar startTV >>= \case + end <- liftBase getPOSIXTime + liftBase . atomically $ readTVar startTV >>= \case Nothing -> pure () -- The action was interrupted before the span was pending. Just start -> do modifyTVar' (tracerPendingCount tracer) (\n -> n - 1) @@ -234,12 +233,12 @@ instance (MonadBaseControl IO m, MonadIO m) => MonadTrace (TraceT m) where addSpanEntry key (TagValue val) = TraceT $ do mbTV <- asks (>>= scopeTags) - ReaderT $ \_ -> for_ mbTV $ \tv -> atomically $ modifyTVar' tv $ Map.insert key val + ReaderT $ \_ -> for_ mbTV $ \tv -> liftBase . atomically $ modifyTVar' tv $ Map.insert key val addSpanEntry key (LogValue val mbTime) = TraceT $ do mbTV <- asks (>>= scopeLogs) ReaderT $ \_ -> for_ mbTV $ \tv -> do - time <- maybe (liftIO getPOSIXTime) pure mbTime - atomically $ modifyTVar' tv ((time, key, val) :) + time <- maybe (liftBase getPOSIXTime) pure mbTime + liftBase . atomically $ modifyTVar' tv ((time, key, val) :) -- | 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 e4583af..628d077 100644 --- a/src/Monitor/Tracing/Local.hs +++ b/src/Monitor/Tracing/Local.hs @@ -7,7 +7,7 @@ module Monitor.Tracing.Local ( import Control.Monad.Trace -import Control.Concurrent.STM.Lifted (atomically, readTVar) +import Control.Concurrent.STM (atomically, readTVar) import Control.Monad.Fix (fix) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl) diff --git a/src/Monitor/Tracing/Zipkin.hs b/src/Monitor/Tracing/Zipkin.hs index 17dee8a..4a21d25 100644 --- a/src/Monitor/Tracing/Zipkin.hs +++ b/src/Monitor/Tracing/Zipkin.hs @@ -45,10 +45,11 @@ import Control.Monad.Trace.Class import Control.Concurrent (threadDelay) import Control.Concurrent.Lifted (fork) -import Control.Concurrent.STM.Lifted (atomically) +import Control.Concurrent.STM (atomically) import Control.Exception (SomeException) import Control.Exception.Lifted (finally, try) import Control.Monad (forever, guard, unless, void) +import Control.Monad.Base (liftBase) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Aeson as JSON @@ -75,7 +76,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 Control.Monad.Base (liftBase) -- | 'Zipkin' creation settings. data Settings = Settings diff --git a/test/Spec.hs b/test/Spec.hs index b88884d..0e9aead 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,7 +10,7 @@ import Monitor.Tracing.Local (collectSpanSamples) import qualified Monitor.Tracing.Zipkin as ZPK import Control.Concurrent.Lifted -import Control.Concurrent.STM.Lifted +import Control.Concurrent.STM import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad (void) import Control.Monad.Reader (MonadReader, Reader, ReaderT, ask, runReader, runReaderT) @@ -101,8 +101,8 @@ main = hspec $ do 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 $ fork $ childSpan "sleep-child" $ atomically (putTMVar tmv ()) >> threadDelay 20000 - void $ atomically $ readTMVar tmv + spans <- collectSpans . rootSpan alwaysSampled "sleep-parent" $ do + tmv <- liftIO newEmptyTMVarIO + void . fork . childSpan "sleep-child" . liftIO $ atomically (putTMVar tmv ()) >> threadDelay 20000 + void . liftIO $ atomically $ readTMVar tmv fmap spanName spans `shouldMatchList` ["sleep-parent", "sleep-child"] diff --git a/tracing.cabal b/tracing.cabal index ccb76f6..3f694b0 100644 --- a/tracing.cabal +++ b/tracing.cabal @@ -45,7 +45,6 @@ library , mtl >= 2.2 , network >= 2.8 , random >= 1.1 - , stm-lifted >= 2.5 , stm >= 2.5 , text >= 1.2 , time >= 1.8 && < 1.10 @@ -65,7 +64,7 @@ test-suite tracing-test , lifted-base >= 0.2.3 , monad-control >= 1.0 , mtl - , stm-lifted >= 2.5 + , stm , text , tracing ghc-options: -threaded -rtsopts -with-rtsopts=-N