{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Logging.FrequencyLimiter (
    limitFrequency
  , LimiterSpec (..)
)where

import           Cardano.Logging.Trace
import           Cardano.Logging.TraceDispatcherMessage
import           Cardano.Logging.Types

import           Control.Monad.IO.Unlift
import qualified Control.Tracer as T
import           Data.Text
import           Data.Time.Clock.System

-- | Threshold for starting and stopping of the limiter
budgetLimit :: Double
budgetLimit :: Double
budgetLimit = Double
30.0

-- | After how many seconds a reminder message is send
reminderPeriod :: Double
reminderPeriod :: Double
reminderPeriod = Double
10.0

data MaybeTuple' a b = Nothing' | Just' !a !b
     deriving Int -> MaybeTuple' a b -> ShowS
[MaybeTuple' a b] -> ShowS
MaybeTuple' a b -> String
(Int -> MaybeTuple' a b -> ShowS)
-> (MaybeTuple' a b -> String)
-> ([MaybeTuple' a b] -> ShowS)
-> Show (MaybeTuple' a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> MaybeTuple' a b -> ShowS
forall a b. (Show a, Show b) => [MaybeTuple' a b] -> ShowS
forall a b. (Show a, Show b) => MaybeTuple' a b -> String
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> MaybeTuple' a b -> ShowS
showsPrec :: Int -> MaybeTuple' a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => MaybeTuple' a b -> String
show :: MaybeTuple' a b -> String
$cshowList :: forall a b. (Show a, Show b) => [MaybeTuple' a b] -> ShowS
showList :: [MaybeTuple' a b] -> ShowS
Show

data LimiterSpec = LimiterSpec {
    LimiterSpec -> [Text]
lsNs        :: [Text]
  , LimiterSpec -> Text
lsName      :: Text
  , LimiterSpec -> Double
lsFrequency :: Double
}

data FrequencyRec a = FrequencyRec {
    forall a. FrequencyRec a -> Maybe a
frMessage  :: Maybe a   -- ^ The message to pass
  , forall a. FrequencyRec a -> Double
frLastTime :: Double    -- ^ The time since the last message did arrive in seconds
  , forall a. FrequencyRec a -> Double
frLastRem  :: Double    -- ^ The time since the last limiting remainder was send
  , forall a. FrequencyRec a -> Double
frBudget   :: Double    -- ^ A budget which is used to decide when to start limiting
                              --   and stop limiting. When messages arrive in shorter frequency then
                              --   by the given thresholdFrequency budget is earned, and if they
                              --   arrive in a longer period budget is spend.
  , forall a. FrequencyRec a -> MaybeTuple' Int Double
frActive   :: !(MaybeTuple' Int Double)
                              -- ^ Just is active and carries the number
                              --   of suppressed messages and the time of last send message
} deriving (Int -> FrequencyRec a -> ShowS
[FrequencyRec a] -> ShowS
FrequencyRec a -> String
(Int -> FrequencyRec a -> ShowS)
-> (FrequencyRec a -> String)
-> ([FrequencyRec a] -> ShowS)
-> Show (FrequencyRec a)
forall a. Show a => Int -> FrequencyRec a -> ShowS
forall a. Show a => [FrequencyRec a] -> ShowS
forall a. Show a => FrequencyRec a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> FrequencyRec a -> ShowS
showsPrec :: Int -> FrequencyRec a -> ShowS
$cshow :: forall a. Show a => FrequencyRec a -> String
show :: FrequencyRec a -> String
$cshowList :: forall a. Show a => [FrequencyRec a] -> ShowS
showList :: [FrequencyRec a] -> ShowS
Show)

-- | Limits the frequency of messages to nMsg which is given per minute.
--
-- If the limiter detects more messages, it traces randomly selected
-- messages with the given frequency on the 'vtracer' until the
-- frequency falls under the threshold long enough.(see below)
--
-- Before this the 'ltracer' gets a 'StartLimiting' message.
-- In-between you receive 'ContinueLimiting' messages on the 'ltracer'
-- every 'reminderPeriod' seconds, with the number of suppressed messages.
-- Finally it sends a 'StopLimiting' message on the 'ltracer' and traces all
-- messages on the 'vtracer' again.
--
-- A budget is used to decide when to start limiting and stop limiting,
-- so that the limiter does not get activated if few messages are send in
-- high frequency, and doesn't get deactivated if their are only few messages
-- which come with low frequency.  When messages arrive in shorter frequency then
-- by the given 'thresholdFrequency' budget is earned, and if they
-- arrive in a longer period budget is spend. If budget is gets higher
-- then 'budgetLimit', the limiter starts, and if it falls below minus 'budgetLimit'
-- the limiter stops.

-- The budget is calculated by 'thresholdPeriod' / 'elapsedTime', which says how
-- many times too quick the message arrives. A value less then 1.0 means the message is
-- arriving slower then threshold. This value gets then normalized, so that
-- (0.0-10.0) means message arrive quicker then threshold and (0.0..-10.0)
-- means that messages arrive slower then threshold.


limitFrequency
  :: forall a m . MonadUnliftIO m
  => Double   -- messages per second
  -> Text     -- name of this limiter
  -> Trace m TraceDispatcherMessage -- the limiters messages
  -> Trace m a -- the limited trace
  -> m (Trace m a) -- the original trace
limitFrequency :: forall a (m :: * -> *).
MonadUnliftIO m =>
Double
-> Text
-> Trace m TraceDispatcherMessage
-> Trace m a
-> m (Trace m a)
limitFrequency Double
thresholdFrequency Text
limiterName Trace m TraceDispatcherMessage
ltracer Trace m a
vtracer = do
    Double
timeNow <- SystemTime -> Double
systemTimeToSeconds (SystemTime -> Double) -> m SystemTime -> m Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemTime -> m SystemTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime
    (FrequencyRec a -> LoggingContext -> a -> m (FrequencyRec a))
-> FrequencyRec a
-> Trace m (Folding a (FrequencyRec a))
-> m (Trace m a)
forall a acc (m :: * -> *).
MonadUnliftIO m =>
(acc -> LoggingContext -> a -> m acc)
-> acc -> Trace m (Folding a acc) -> m (Trace m a)
foldTraceM
      (Double
-> FrequencyRec a -> LoggingContext -> a -> m (FrequencyRec a)
checkLimiting (Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
thresholdFrequency))
      (Maybe a
-> Double
-> Double
-> Double
-> MaybeTuple' Int Double
-> FrequencyRec a
forall a.
Maybe a
-> Double
-> Double
-> Double
-> MaybeTuple' Int Double
-> FrequencyRec a
FrequencyRec Maybe a
forall a. Maybe a
Nothing Double
timeNow Double
0.0 Double
0.0 MaybeTuple' Int Double
forall a b. MaybeTuple' a b
Nothing')
      (Tracer
  m
  (LoggingContext, Either TraceControl (Folding a (FrequencyRec a)))
-> Trace m (Folding a (FrequencyRec a))
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer
   m
   (LoggingContext, Either TraceControl (Folding a (FrequencyRec a)))
 -> Trace m (Folding a (FrequencyRec a)))
-> Tracer
     m
     (LoggingContext, Either TraceControl (Folding a (FrequencyRec a)))
-> Trace m (Folding a (FrequencyRec a))
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl (Folding a (FrequencyRec a)))
 -> (LoggingContext, Either TraceControl (Maybe a)))
-> Tracer m (LoggingContext, Either TraceControl (Maybe a))
-> Tracer
     m
     (LoggingContext, Either TraceControl (Folding a (FrequencyRec a)))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap (LoggingContext, Either TraceControl (Folding a (FrequencyRec a)))
-> (LoggingContext, Either TraceControl (Maybe a))
unfoldTrace (Trace m (Maybe a)
-> Tracer m (LoggingContext, Either TraceControl (Maybe a))
forall (m :: * -> *) a.
Trace m a -> Tracer m (LoggingContext, Either TraceControl a)
unpackTrace (Trace m a -> Trace m (Maybe a)
forall (m :: * -> *) a. Monad m => Trace m a -> Trace m (Maybe a)
filterTraceMaybe Trace m a
vtracer)))
  where
    checkLimiting ::
         Double
      -> FrequencyRec a
      -> LoggingContext
      -> a
      -> m (FrequencyRec a)
    checkLimiting :: Double
-> FrequencyRec a -> LoggingContext -> a -> m (FrequencyRec a)
checkLimiting Double
thresholdPeriod fs :: FrequencyRec a
fs@FrequencyRec{Double
Maybe a
MaybeTuple' Int Double
frMessage :: forall a. FrequencyRec a -> Maybe a
frLastTime :: forall a. FrequencyRec a -> Double
frLastRem :: forall a. FrequencyRec a -> Double
frBudget :: forall a. FrequencyRec a -> Double
frActive :: forall a. FrequencyRec a -> MaybeTuple' Int Double
frMessage :: Maybe a
frLastTime :: Double
frLastRem :: Double
frBudget :: Double
frActive :: MaybeTuple' Int Double
..} LoggingContext
lc a
message = do
      Double
timeNow <- IO Double -> m Double
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> m Double) -> IO Double -> m Double
forall a b. (a -> b) -> a -> b
$ SystemTime -> Double
systemTimeToSeconds (SystemTime -> Double) -> IO SystemTime -> IO Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemTime
getSystemTime
      let elapsedTime :: Double
elapsedTime      = Double
timeNow Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
frLastTime
      -- How many times too quick does the message arrive (thresholdPeriod / elapsedTime)
      -- A value less then 1.0 means the message is
      -- arriving slower then threshold
      let rawSpendReward :: Double
rawSpendReward   = if Double
elapsedTime Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0.0
                                then Double
10.0
                                else Double
thresholdPeriod Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
elapsedTime
      let spendReward :: Double
spendReward = if Double
rawSpendReward Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1.0 Bool -> Bool -> Bool
&& Double
rawSpendReward Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0.0
                                then Double
1.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
rawSpendReward)
                                else Double
rawSpendReward Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1.0
      -- Normalize so that (0.0-10.0) means message
      -- arrive quicker then threshold
      -- and (0.0..-10.0) means that messages arrive
      -- slower then threshold
      let normaSpendReward :: Double
normaSpendReward = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
10.0 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (-Double
10.0) Double
spendReward)
      let newBudget :: Double
newBudget        = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
budgetLimit (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (-Double
budgetLimit)
                                  (Double
normaSpendReward Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
frBudget))
      case MaybeTuple' Int Double
frActive of
        MaybeTuple' Int Double
Nothing' -> -- limiter not active
          if Double
normaSpendReward Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
frBudget Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
budgetLimit
            then do  -- start limiting
              Trace m TraceDispatcherMessage -> TraceDispatcherMessage -> m ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith
                ([Text]
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text
"Reflection"]
                                   (SeverityS
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a.
Monad m =>
SeverityS -> Trace m a -> Trace m a
setSeverity SeverityS
Info (LoggingContext
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a.
Monad m =>
LoggingContext -> Trace m a -> Trace m a
withLoggingContext LoggingContext
lc Trace m TraceDispatcherMessage
ltracer)))
                (Text -> TraceDispatcherMessage
StartLimiting Text
limiterName)
              FrequencyRec a -> m (FrequencyRec a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrequencyRec a
fs  { frMessage     = Just message
                       , frLastTime    = timeNow
                       , frLastRem     = timeNow
                       , frBudget      = newBudget
                       , frActive      = Just' 0 timeNow
                       }
            else  -- continue without limiting
              FrequencyRec a -> m (FrequencyRec a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrequencyRec a
fs  { frMessage     = Just message
                       , frLastTime    = timeNow
                       , frLastRem     = 0.0
                       , frBudget      = newBudget
                       }
        Just' Int
nSuppressed Double
lastTimeSend -> -- is active
           if Double
normaSpendReward Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
frBudget Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= (- Double
budgetLimit)
            then do -- stop limiting
              Trace m TraceDispatcherMessage -> TraceDispatcherMessage -> m ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith
                ([Text]
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames  [Text
"Reflection"]
                                    (SeverityS
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a.
Monad m =>
SeverityS -> Trace m a -> Trace m a
setSeverity SeverityS
Info (LoggingContext
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a.
Monad m =>
LoggingContext -> Trace m a -> Trace m a
withLoggingContext LoggingContext
lc Trace m TraceDispatcherMessage
ltracer)))
                (Text -> Int -> TraceDispatcherMessage
StopLimiting Text
limiterName Int
nSuppressed)
              FrequencyRec a -> m (FrequencyRec a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrequencyRec a
fs  { frMessage     = Just message
                       , frLastTime    = timeNow
                       , frBudget      = newBudget
                       , frActive      = Nothing'
                       }
            else
              let lastPeriod :: Double
lastPeriod = Double
timeNow Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
lastTimeSend
                  lastReminder :: Double
lastReminder = Double
timeNow Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
frLastRem
              in do
                Double
newFrLastRem <- if Double
lastReminder Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
reminderPeriod
                                  then do
                                    Trace m TraceDispatcherMessage -> TraceDispatcherMessage -> m ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith
                                      ([Text]
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text
"Reflection"]
                                        (SeverityS
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a.
Monad m =>
SeverityS -> Trace m a -> Trace m a
setSeverity SeverityS
Info
                                          (LoggingContext
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a.
Monad m =>
LoggingContext -> Trace m a -> Trace m a
withLoggingContext LoggingContext
lc Trace m TraceDispatcherMessage
ltracer)))
                                      (Text -> Int -> TraceDispatcherMessage
RememberLimiting Text
limiterName Int
nSuppressed)
                                    Double -> m Double
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
timeNow
                                  else Double -> m Double
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
frLastRem
                if Double
lastPeriod Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
thresholdPeriod
                  then -- send
                    FrequencyRec a -> m (FrequencyRec a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrequencyRec a
fs  { frMessage     = Just message
                             , frLastTime    = timeNow
                             , frLastRem     = newFrLastRem
                             , frBudget      = newBudget
                             , frActive      = Just' nSuppressed timeNow
                             }
                  else  -- suppress
                    FrequencyRec a -> m (FrequencyRec a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrequencyRec a
fs  { frMessage     = Nothing
                             , frLastTime    = timeNow
                             , frLastRem     = newFrLastRem
                             , frBudget      = newBudget
                             , frActive      = Just' (nSuppressed + 1) lastTimeSend
                             }
    unfoldTrace ::
         (LoggingContext, Either TraceControl (Folding a (FrequencyRec a)))
      -> (LoggingContext, Either TraceControl (Maybe a))
    unfoldTrace :: (LoggingContext, Either TraceControl (Folding a (FrequencyRec a)))
-> (LoggingContext, Either TraceControl (Maybe a))
unfoldTrace (LoggingContext
lc, Right (Folding FrequencyRec {Double
Maybe a
MaybeTuple' Int Double
frMessage :: forall a. FrequencyRec a -> Maybe a
frLastTime :: forall a. FrequencyRec a -> Double
frLastRem :: forall a. FrequencyRec a -> Double
frBudget :: forall a. FrequencyRec a -> Double
frActive :: forall a. FrequencyRec a -> MaybeTuple' Int Double
frMessage :: Maybe a
frLastTime :: Double
frLastRem :: Double
frBudget :: Double
frActive :: MaybeTuple' Int Double
..})) = (LoggingContext
lc, Maybe a -> Either TraceControl (Maybe a)
forall a b. b -> Either a b
Right Maybe a
frMessage)
    unfoldTrace (LoggingContext
lc, Left TraceControl
ctrl) = (LoggingContext
lc, TraceControl -> Either TraceControl (Maybe a)
forall a b. a -> Either a b
Left TraceControl
ctrl)


    systemTimeToSeconds :: SystemTime -> Double
    systemTimeToSeconds :: SystemTime -> Double
systemTimeToSeconds MkSystemTime {Int64
Word32
systemSeconds :: Int64
systemNanoseconds :: Word32
systemSeconds :: SystemTime -> Int64
systemNanoseconds :: SystemTime -> Word32
..} =
      Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
systemSeconds Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Word32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
systemNanoseconds Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1.0E-9