FrequencyLimiter and Aeson instances

trace-dispatcher/src/Cardano/Logging.hs

@@ -2,8 +2,9 @@ module Cardano.Logging (
     module X
   ) where
 
-import           Cardano.Logging.Types as X
-import           Cardano.Logging.Trace as X
 import           Cardano.Logging.Configuration as X
+import           Cardano.Logging.FrequencyLimiter as X
+import           Cardano.Logging.Trace as X
 import           Cardano.Logging.Tracer.EKG as X
 import           Cardano.Logging.Tracer.Katip as X
+import           Cardano.Logging.Types as X

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

@@ -2,8 +2,12 @@
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-
-module Cardano.Logging.Configuration where
+module Cardano.Logging.Configuration
+  ( configureTracers
+  , withNamespaceConfig
+  , filterSeverityFromConfig
+  , filterPrivacyFromConfig
+  ) where
 
 import           Control.Monad.IO.Class (MonadIO, liftIO)
 import qualified Control.Tracer as T
@@ -26,18 +30,6 @@ configureTracers config tracers = do
     configureTrace :: Monad m => TraceControl -> Trace m a -> m ()
     configureTrace c tr = T.traceWith tr (emptyLoggingContext, Left c)
 
--- | Filter a trace by severity and take the filter value from the config
-filterSeverityFromConfig :: (MonadIO m) =>
-     Trace m a
-  -> m (Trace m a)
-filterSeverityFromConfig = withNamespaceConfig getSeverity filterTraceBySeverity
-
--- | Filter a trace by severity and take the filter value from the config
-filterPrivacyFromConfig :: (MonadIO m) =>
-     Trace m a
-  -> m (Trace m a)
-filterPrivacyFromConfig = withNamespaceConfig getPrivacy filterTraceByPrivacy
-
 -- | Take a selector function, and a function from trace to trace with
 --   this selector to make a trace transformer with a config value
 withNamespaceConfig :: (MonadIO m, Eq b) =>
@@ -95,6 +87,21 @@ withNamespaceConfig extract needsConfigFunc tr = do
         Right val -> error $ "Trace not reset before reconfiguration "
                             ++ show (lcContext lc)
 
+-- | Filter a trace by severity and take the filter value from the config
+filterSeverityFromConfig :: (MonadIO m) =>
+     Trace m a
+  -> m (Trace m a)
+filterSeverityFromConfig = withNamespaceConfig getSeverity filterTraceBySeverity
+
+-- | Filter a trace by severity and take the filter value from the config
+filterPrivacyFromConfig :: (MonadIO m) =>
+     Trace m a
+  -> m (Trace m a)
+filterPrivacyFromConfig = withNamespaceConfig getPrivacy filterTraceByPrivacy
+
+--------------------------------------------------------
+-- Internal
+
 -- | If no severity can be found in the config, it is set to Warning
 getSeverity :: TraceConfig -> Namespace -> SeverityF
 getSeverity config context =

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

@@ -1,31 +1,41 @@
+{-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
+
 module Cardano.Logging.FrequencyLimiter where
 
 import           Control.Monad.IO.Class (MonadIO, liftIO)
 import qualified Control.Tracer as T
-import           Data.Text (Text)
+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           Debug.Trace
+import           GHC.Generics
 import           System.Random
 
 import           Cardano.Logging.Trace
 import           Cardano.Logging.Types
 
 data LimitingMessage =
-    StartLimiting Text Double
-  | ContinueLimiting Text Double  -- Should be shown only for debugging
-  | StopLimiting Text
+    StartLimiting {name :: Text, factor :: Double}
+  | ContinueLimiting {name :: Text, factor :: Double}  -- Should be shown only for debugging
+  | StopLimiting {name :: Text, factor :: Double}
+  deriving (Eq, Ord, Show, Generic)
+
+instance A.ToJSON LimitingMessage where
+    toEncoding = A.genericToEncoding A.defaultOptions
 
 data FrequencyRec a = FrequencyRec {
     frMessage  :: Maybe a
   , frLastTime :: UTCTime
   , frMsgCount :: Int
   , frTicks    :: Int
-  , frActive   :: Maybe Double
-}
+  , frActive   :: Maybe Double}
+  deriving (Show)
 
 -- | Limits the frequency of messages to nMsg which is given per minute.
 
@@ -41,16 +51,17 @@ data FrequencyRec a = FrequencyRec {
 -- messages on the vtracer again.
 limitFrequency
   :: forall a acc m . MonadIO m
-  => Int
-  -> Text
-  -> Trace m a
-  -> Trace m LimitingMessage
-  -> m (Trace m a)
+  => Int   -- messages per minute
+  -> Text  -- name of this limiter
+  -> Trace m a -- the limited trace
+  -> Trace m LimitingMessage -- the limiters messages
+  -> m (Trace m a) -- the original trace
 limitFrequency nMsg limiterName vtracer ltracer =
     let ticks = max 1 (round (5.0 * (60.0 / fromIntegral nMsg)))
         treshold = (fromIntegral nMsg / 60.0) * fromIntegral ticks
     in do
-      timeNow <- liftIO getCurrentTime
+      timeNow <- trace ("name : "++ unpack limiterName ++ " ticks: " ++ show ticks ++ " treshold: " ++ show treshold) $
+        liftIO getCurrentTime
       foldMTraceM
         (cata ticks treshold)
         (FrequencyRec Nothing timeNow 0 0 Nothing)
@@ -65,16 +76,15 @@ limitFrequency nMsg limiterName vtracer ltracer =
     cata :: Int -> Double -> FrequencyRec a -> a -> m (FrequencyRec a)
     cata ticks treshold fs@FrequencyRec {..} message = do
       timeNow <- liftIO getCurrentTime
-      let timeDiffPico = nominalDiffTimeToSeconds (diffUTCTime timeNow frLastTime)
-      let timeDiffSec  = timeDiffPico * 1000000000000.00
+      let timeDiffSec = nominalDiffTimeToSeconds (diffUTCTime timeNow frLastTime)
       case frActive of
-        Nothing ->  -- not active
+        Nothing ->  trace ("inactive timeDiffSec: " ++ show timeDiffSec) $ -- not active
           if timeDiffSec > 1.0
-            then -- ticking
-              if frTicks + 1 >= ticks
-                then -- in a check cycle
+            then trace "ticking passive" $ -- ticking
+              if frTicks >= ticks
+                then trace ("checking frMsgCount: " ++ show frMsgCount ++ " treshold: " ++ show treshold) $ -- in a check cycle
                   if fromIntegral frMsgCount > treshold
-                    then do -- start limiting
+                    then trace "start limiting" $ do -- start limiting
                       let limitingFactor = treshold / fromIntegral frMsgCount
                       traceWith
                         (setSeverity Info ltracer)
@@ -92,51 +102,70 @@ limitFrequency nMsg limiterName vtracer ltracer =
                                , frActive    = Nothing}
                 else -- ticking but not in a check cycle
                   if fromIntegral frMsgCount > treshold
-                    then do -- start limiting inbetween
+                    then trace ("start limiting 2 ticks: "  ++ show ticks ++ " frTicks: " ++ show frTicks
+                                ++ " frMsgCount: " ++ show frMsgCount ++ " treshold: " ++ show treshold) $ do  -- start limiting inbetween
                       let preFactor = fromIntegral ticks / fromIntegral (frTicks + 1)
-                      let limitingFactor = (treshold * preFactor) / fromIntegral frMsgCount
+                      let limitingFactor = treshold / (fromIntegral frMsgCount * preFactor)
                       traceWith
                         (setSeverity Info ltracer)
                         (StartLimiting limiterName limitingFactor)
                       pure fs  { frMessage   = Just message
                                , frLastTime  = timeNow
-                               , frMsgCount  = 0
                                , frTicks     = 0
+                               , frMsgCount  = 0
                                , frActive    = Just limitingFactor}
                     else
                       pure fs  { frMessage   = Just message
                                , frLastTime  = timeNow
-                               , frMsgCount  = 0
+                               , frMsgCount  = frMsgCount + 1
                                , frTicks     = frTicks + 1}
             -- Not active, not at second boundary, just pass and count
             else pure $ fs  { frMessage   = Just message
                             , frMsgCount  = frMsgCount + 1}
-        Just percentage -> -- Active
-          if (timeDiffSec > 1.0) && (frTicks + 1 >= ticks)
-            then -- active, second and ticking
-              (if fromIntegral frMsgCount > treshold
-                then do -- continue
-                  let limitingFactor = treshold / fromIntegral frMsgCount
-                  traceWith
-                   (setSeverity Debug ltracer)
-                   (ContinueLimiting limiterName limitingFactor)
-                  pure fs
-                     {frMessage = Just message, frLastTime = timeNow, frMsgCount = 0,
-                      frTicks = 0, frActive = Just limitingFactor}
-                else do -- stop
-                  traceWith (setSeverity Info ltracer) (StopLimiting limiterName)
-                  pure fs
-                    {frMessage = Just message, frLastTime = timeNow, frMsgCount = 0,
-                     frTicks = 0, frActive = Nothing})
+        Just percentage ->  -- Active
+          if timeDiffSec > 1.0
+            then trace ("ticking active " ++ unpack limiterName) $
+              if frTicks >= ticks
+                then trace ("checking frMsgCount: " ++ show frMsgCount ++ " treshold: " ++ show treshold)  $ -- ticking-- active, second and ticking
+                  if fromIntegral frMsgCount > treshold
+                    then trace "stay active " $ do -- continue
+                      let limitingFactor = treshold / fromIntegral frMsgCount
+                      traceWith
+                       (setSeverity Debug ltracer)
+                       (ContinueLimiting limiterName limitingFactor)
+                      pure fs
+                         {frMessage = Just message,
+                          frLastTime = timeNow,
+                          frMsgCount = 0,
+                          frTicks = 0,
+                          frActive = Just limitingFactor}
+                    else trace "stop active " $ do -- stop
+                      traceWith (setSeverity Info ltracer) (StopLimiting limiterName 1.0)
+                      pure fs
+                         {frMessage = Just message,
+                          frLastTime = timeNow,
+                          frMsgCount = 0,
+                          frTicks = 0,
+                          frActive = Nothing}
+                else do -- ticking
+                  rnd :: Double <- liftIO randomIO
+                  if percentage > rnd
+                    then -- sending the message
+                      pure $ fs  { frMessage   = Just message
+                                 , frLastTime  = timeNow
+                                 , frTicks     = frTicks + 1
+                                 , frMsgCount  = frMsgCount + 1}
+                    else -- suppress the message
+                      pure  $ fs { frMessage   = Nothing
+                                 , frLastTime  = timeNow
+                                 , frTicks     = frTicks + 1
+                                 , frMsgCount  = frMsgCount + 1}
             else do
               rnd :: Double <- liftIO randomIO
-              let newTicks = if timeDiffSec > 1.0 then frTicks + 1 else frTicks
               if percentage > rnd
                 then -- sending the message
                   pure $ fs  { frMessage   = Just message
-                             , frTicks     = newTicks
                              , frMsgCount  = frMsgCount + 1}
                 else -- suppress the message
                   pure  $ fs { frMessage   = Nothing
-                             , frTicks     = newTicks
                              , frMsgCount  = frMsgCount + 1}

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}

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

@@ -26,6 +26,13 @@ traceWith tr a = T.traceWith tr (emptyLoggingContext, Right a)
 traceNamed :: (Monad m) => Trace m a -> Text -> a -> m ()
 traceNamed tr n = traceWith (appendName n tr)
 
+-- | Contramap lifted to Trace
+cmap :: Monad m => (a -> b) -> Trace m b -> Trace m a
+cmap f = T.contramap
+          (\case
+            (lc, Right a) -> (lc, Right (f a))
+            (lc, Left  c) -> (lc, Left  c))
+
 --- | Don't process further if the result of the selector function
 ---   is False.
 filterTrace :: (Monad m) =>
@@ -37,7 +44,7 @@ filterTrace ff = T.squelchUnless $
       (lc, Right a) -> ff (lc, a)
       (lc, Left  c) -> True
 
---- | Just keep the Just values and forget about the Nothings
+--- | Keep the Just values and forget about the Nothings
 filterTraceMaybe :: Monad m =>
      Trace m a
   -> Trace m (Maybe a)