With MVar and MonadUnliftIO

trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs

@@ -3,20 +3,17 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-
 module Cardano.Logging.FrequencyLimiter where
 
 import           Control.Monad.IO.Class (MonadIO, liftIO)
+import           Control.Monad.IO.Unlift
 import qualified Control.Tracer as T
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Types as A
 import           Data.Text (Text, unpack)
--- import           Data.Time (UTCTime, diffUTCTime, getCurrentTime,
---                      nominalDiffTimeToSeconds)
 import           Data.Time.Clock.System
 import           Debug.Trace
 import           GHC.Generics
-import           System.Random
 
 import           Cardano.Logging.Trace
 import           Cardano.Logging.Types
@@ -56,7 +53,7 @@ data FrequencyRec a = FrequencyRec {
 -- Finally it sends a StopLimiting message on the ltracer and traces all
 -- messages on the vtracer again.
 limitFrequency
-  :: forall a acc m . MonadIO m
+  :: forall a acc m . (MonadIO m, MonadUnliftIO m)
   => Double   -- messages per second
   -> Text     -- name of this limiter
   -> Trace m a -- the limited trace
@@ -77,7 +74,7 @@ limitFrequency nMsgPerSecond limiterName vtracer ltracer = do
 
     cata :: FrequencyRec a -> a -> m (FrequencyRec a)
     cata fs@FrequencyRec {..} message = do
-      timeNow <- systemTimeToSeconds <$> liftIO getSystemTime
+      timeNow <- liftIO $ systemTimeToSeconds <$> getSystemTime
       let realTimeBetweenMsgs = timeNow - frLastTime
       let canoTimeBetweenMsgs = 1.0 / nMsgPerSecond
       let diffTimeBetweenMsgs = realTimeBetweenMsgs - canoTimeBetweenMsgs

trace-dispatcher/src/Cardano/Logging/Trace.hs

@@ -9,12 +9,12 @@ module Cardano.Logging.Trace where
 import           Control.Arrow
 import           Control.Monad (join)
 import           Control.Monad.IO.Class (MonadIO, liftIO)
+import           Control.Monad.IO.Unlift
 import qualified Control.Tracer as T
 import qualified Control.Tracer.Arrow as TA
-import           Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef,
-                     writeIORef)
 import           Data.Maybe (fromMaybe, isJust)
 import           Data.Text (Text)
+import           UnliftIO.MVar
 
 import           Cardano.Logging.Types
 
@@ -140,48 +140,48 @@ withDetails fs = T.contramap $
       (lc, Left  c) -> (lc, Left c)
 
 -- | Folds the cata function with acc over a.
--- Uses an IORef to store the state
+-- Uses an MVar to store the state
 foldTraceM
-  :: forall a acc m . MonadIO m
+  :: forall a acc m . (MonadUnliftIO m, MonadIO m)
   => (acc -> a -> acc)
   -> acc
   -> Trace m (Folding a acc)
   -> m (Trace m a)
 foldTraceM cata initial tr = do
-  ref <- liftIO (newIORef initial)
+  ref <- liftIO (newMVar initial)
   let trr = mkTracer ref
   pure (T.Tracer trr)
  where
     mkTracer ref = T.emit $
       \case
         (lc, Right v) -> do
-          x' <- liftIO $ atomicModifyIORef' ref $ \x ->
+          x' <- modifyMVar ref $ \x ->
             let ! accu = cata x v
-            in join (,) accu
+            in pure $ join (,) accu
           T.traceWith tr (lc, Right (Folding x'))
         (lc, Left c) -> do
           T.traceWith tr (lc, Left c)
 
 -- | Folds the monadic cata function with acc over a.
 -- Uses an IORef to store the state
 foldMTraceM
-  :: forall a acc m . MonadIO m
+  :: forall a acc m . (MonadUnliftIO m, MonadIO m)
   => (acc -> a -> m acc)
   -> acc
   -> Trace m (Folding a acc)
   -> m (Trace m a)
 foldMTraceM cata initial tr = do
-  ref <- liftIO (newIORef initial)
+  ref <- liftIO (newMVar initial)
   let trr = mkTracer ref
   pure (T.arrow trr)
  where
     mkTracer ref = T.emit $
       \case
         (lc, Right v) -> do
-          acc    <- liftIO $ readIORef ref
-          ! acc' <- cata acc v
-          liftIO $ writeIORef ref acc'
-          T.traceWith tr (lc, Right (Folding acc'))
+          x' <- modifyMVar ref $ \x -> do
+            ! accu <- cata x v
+            pure $ join (,) accu
+          T.traceWith tr (lc, Right (Folding x'))
         (lc, Left c) -> do
           T.traceWith tr (lc, Left c)
 

trace-dispatcher/test/Examples/FrequencyLimiting.hs

@@ -7,6 +7,7 @@ module Examples.FrequencyLimiting where
 import           Control.Concurrent
 import           Control.Monad (liftM)
 import           Control.Monad.IO.Class
+import           Control.Monad.IO.Unlift
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Types as A
 import           GHC.Generics
@@ -17,12 +18,12 @@ import           Examples.TestObjects
 data LOX = LOS LO | LOL LimitingMessage
  deriving (Logging, Generic, A.ToJSON)
 
-tracer1 :: MonadIO m => m (Trace m LO)
+tracer1 :: (MonadIO m, MonadUnliftIO m) => m (Trace m LO)
 tracer1  = do
   t1      <- fmap (appendName "tracer1") stdoutObjectKatipTracer
   limitFrequency 5 "5 messages per second" (cmap LOS t1) (cmap LOL t1)
 
-tracer2 :: MonadIO m => m (Trace m LO)
+tracer2 :: (MonadIO m, MonadUnliftIO m) => m (Trace m LO)
 tracer2  = do
   t2      <- fmap (appendName "tracer2") stdoutJsonKatipTracer
   limitFrequency 15 "15 messages per second" (cmap LOS t2) (cmap LOL t2)

trace-dispatcher/trace-dispatcher.cabal

@@ -31,10 +31,11 @@ library
                       , ekg-core
                       , hostname
                       , katip
-                      , random
                       , stm
                       , text
                       , time
+                      , unliftio
+                      , unliftio-core
                       , unordered-containers
 
 executable trace-dispatcher-examples
@@ -56,9 +57,10 @@ executable trace-dispatcher-examples
                       , ekg-core
                       , hostname
                       , katip
-                      , random
                       , text
                       , trace-dispatcher
                       , time
+                      , unliftio
+                      , unliftio-core
                       , stm
                       , unordered-containers