diff --git a/trace-dispatcher/src/Cardano/Logging.hs b/trace-dispatcher/src/Cardano/Logging.hs index 04eef075767..7db9035187b 100644 --- a/trace-dispatcher/src/Cardano/Logging.hs +++ b/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 diff --git a/trace-dispatcher/src/Cardano/Logging/Configuration.hs b/trace-dispatcher/src/Cardano/Logging/Configuration.hs index 916702382e8..1ad3e5433e1 100644 --- a/trace-dispatcher/src/Cardano/Logging/Configuration.hs +++ b/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 = diff --git a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs index 565c736d3cc..d8690d0398c 100644 --- a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs +++ b/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} diff --git a/trace-dispatcher/src/Cardano/Logging/PureFold.hs b/trace-dispatcher/src/Cardano/Logging/PureFold.hs index 7b5390ff7a3..fd9bb3b440b 100644 --- a/trace-dispatcher/src/Cardano/Logging/PureFold.hs +++ b/trace-dispatcher/src/Cardano/Logging/PureFold.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs index 105ae8d219e..676de33c363 100644 --- a/trace-dispatcher/src/Cardano/Logging/Trace.hs +++ b/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) diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs index 107274da53b..c8e62becb09 100644 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -15,10 +16,6 @@ import Data.Text (Text) import GHC.Generics -class Humanise a where - -- | Give a human readable representation for object a - humanise :: a -> Text - -- | Every message needs this to define how to represent it class Logging a where -- | Machine readable representation with the possibility to represent @@ -32,10 +29,8 @@ class Logging a where _ -> mempty -- | Human readable representation. - -- Falls back to Humanise in the default representation forHuman :: a -> Text - default forHuman :: Humanise a => a -> Text - forHuman v = humanise v + forHuman v = "" -- | Metrics representation. -- No metrics by default @@ -49,7 +44,7 @@ data Metric -- | A double metric. -- If a text is given it is appended as last element to the namespace | DoubleM (Maybe Text) Double - deriving (Show, Eq) + deriving (Show, Eq, Generic) type Namespace = [Text] type Selector = [Text] @@ -62,21 +57,21 @@ data LoggingContext = LoggingContext { lcContext :: Namespace , lcSeverity :: Maybe SeverityS , lcPrivacy :: Maybe Privacy - , lcDetails :: Maybe DetailLevel -} + , lcDetails :: Maybe DetailLevel} + deriving (Show, Eq, Generic) emptyLoggingContext :: LoggingContext emptyLoggingContext = LoggingContext [] Nothing Nothing Nothing -- | Formerly known as verbosity data DetailLevel = DBrief | DRegular | DDetailed - deriving (Show, Eq, Ord, Bounded, Enum) + deriving (Show, Eq, Ord, Bounded, Enum, Generic) -- | Privacy of a message data Privacy = Public -- ^ can be public. | Confidential -- ^ confidential information - handle with care - deriving (Show, Eq, Ord, Bounded, Enum) + deriving (Show, Eq, Ord, Bounded, Enum, Generic) -- | Severity of a message data SeverityS @@ -88,7 +83,7 @@ data SeverityS | Critical -- ^ Severe situations | Alert -- ^ Take immediate action | Emergency -- ^ System is unusable - deriving (Eq, Ord, Show, Enum, Bounded) + deriving (Show, Eq, Ord, Bounded, Enum, Generic) -- | Severity for a filter data SeverityF @@ -101,8 +96,7 @@ data SeverityF | AlertF -- ^ Take immediate action | EmergencyF -- ^ System is unusable | SilenceF -- ^ Don't show anything - deriving (Eq, Ord, Show, Enum, Bounded) - + deriving (Show, Eq, Ord, Bounded, Enum, Generic) -- Configuration options for individual namespace elements data ConfigOption = @@ -112,6 +106,7 @@ data ConfigOption = | CoDetail DetailLevel -- | Privacy level (Default is Public) | CoPrivacy Privacy + deriving (Eq, Ord, Show, Generic) data TraceConfig = TraceConfig { @@ -141,6 +136,7 @@ data TraceConfig = TraceConfig { -- Host/port to bind Prometheus server at -- , tcBindAddrPrometheus :: Maybe (String,Int) } + deriving (Eq, Ord, Show, Generic) emptyTraceConfig = TraceConfig {tcOptions = Map.empty} @@ -159,3 +155,27 @@ instance Logging b => Logging (Folding a b) where forMachine v (Folding b) = forMachine v b forHuman (Folding b) = forHuman b asMetrics (Folding b) = asMetrics b + +instance A.ToJSON Metric where + toEncoding = A.genericToEncoding A.defaultOptions + +instance A.ToJSON LoggingContext where + toEncoding = A.genericToEncoding A.defaultOptions + +instance A.ToJSON DetailLevel where + toEncoding = A.genericToEncoding A.defaultOptions + +instance A.ToJSON Privacy where + toEncoding = A.genericToEncoding A.defaultOptions + +instance A.ToJSON SeverityS where + toEncoding = A.genericToEncoding A.defaultOptions + +instance A.ToJSON SeverityF where + toEncoding = A.genericToEncoding A.defaultOptions + +instance A.ToJSON ConfigOption where + toEncoding = A.genericToEncoding A.defaultOptions + +instance A.ToJSON TraceConfig where + toEncoding = A.genericToEncoding A.defaultOptions diff --git a/trace-dispatcher/test/Examples/Aggregation.hs b/trace-dispatcher/test/Examples/Aggregation.hs index 3c72b5aa4fc..859aea28f6a 100644 --- a/trace-dispatcher/test/Examples/Aggregation.hs +++ b/trace-dispatcher/test/Examples/Aggregation.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} @@ -8,7 +7,7 @@ module Examples.Aggregation where -import qualified Data.Aeson as AE +import qualified Data.Aeson as A import GHC.Generics (Generic) import Katip import Katip.Scribes.Handle (ioLogEnv) @@ -21,12 +20,12 @@ data BaseStats = BaseStats { bsMax :: Double, bsCount :: Int, bsSum :: Double - } deriving (Generic, ToObject, AE.ToJSON, Show) + } deriving (Eq, Ord, Show, Generic) +instance A.ToJSON BaseStats where + toEncoding = A.genericToEncoding A.defaultOptions instance Logging BaseStats where - forMachine _ _ = mempty - forHuman _ = "" asMetrics BaseStats {..} = [ DoubleM (Just "measure") bsMeasure , DoubleM (Just "sum") bsSum] diff --git a/trace-dispatcher/test/Examples/EKG.hs b/trace-dispatcher/test/Examples/EKG.hs index 0cb0bf8be5a..825d9bba43a 100644 --- a/trace-dispatcher/test/Examples/EKG.hs +++ b/trace-dispatcher/test/Examples/EKG.hs @@ -9,9 +9,6 @@ import System.Remote.Monitoring (forkServer) instance Logging Int where asMetrics i = [IntM Nothing i] -instance Humanise Int where - humanise i = (pack . show) i - testEKG :: IO () testEKG = do server <- forkServer "localhost" 8000 diff --git a/trace-dispatcher/test/Examples/FrequencyLimiting.hs b/trace-dispatcher/test/Examples/FrequencyLimiting.hs new file mode 100644 index 00000000000..2c7830737de --- /dev/null +++ b/trace-dispatcher/test/Examples/FrequencyLimiting.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + + +module Examples.FrequencyLimiting where + +import Control.Concurrent +import Control.Monad (liftM) +import Control.Monad.IO.Class +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import GHC.Generics + +import Cardano.Logging +import Examples.TestObjects + +data LOX = LOS LO | LOL LimitingMessage + deriving (Logging, Generic, A.ToJSON) + +tracer1 :: MonadIO m => m (Trace m LO) +tracer1 = do + t1 <- fmap (appendName "tracer1") stdoutObjectKatipTracer + limitFrequency 30 "one every 2 seconds" (cmap LOS t1) (cmap LOL t1) + +tracer2 :: MonadIO m => m (Trace m LO) +tracer2 = do + t2 <- fmap (appendName "tracer2") stdoutJsonKatipTracer + limitFrequency 15 "one every four seconds" (cmap LOS t2) (cmap LOL t2) + +repeated :: Trace IO LO -> Int -> Int -> IO () +repeated _ 0 _ = pure () +repeated t n d = do + traceWith t (LO1 n) + threadDelay d + repeated t (n-1) d + +testLimiting :: IO () +testLimiting = do + t1 <- tracer1 + t2 <- tracer2 + let t = t1 <> t2 + repeated t 1000 10000 --wait 100 per second + repeated t 100 100000 --wait 10 per second + repeated t 30 200000 -- wait 5 per second diff --git a/trace-dispatcher/test/Main.hs b/trace-dispatcher/test/Main.hs index d2e7675858b..c7941aa0b93 100644 --- a/trace-dispatcher/test/Main.hs +++ b/trace-dispatcher/test/Main.hs @@ -4,6 +4,7 @@ import Cardano.Logging import Examples.Aggregation import Examples.Configuration import Examples.EKG +import Examples.FrequencyLimiting import Examples.Routing import Examples.Trivial @@ -11,9 +12,10 @@ import Examples.Trivial main :: IO () main = do - test1 - test2 - testAggregation - testRouting - testConfig - testEKG + -- test1 + -- test2 + -- testAggregation + -- testRouting + -- testConfig + -- testEKG + testLimiting diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal index 3e676bb253e..62748374ec9 100644 --- a/trace-dispatcher/trace-dispatcher.cabal +++ b/trace-dispatcher/trace-dispatcher.cabal @@ -45,6 +45,7 @@ executable trace-dispatcher-examples Examples.Routing Examples.EKG Examples.Configuration + Examples.FrequencyLimiting hs-source-dirs: test default-language: Haskell2010 default-extensions: OverloadedStrings @@ -55,7 +56,7 @@ executable trace-dispatcher-examples , ekg-core , hostname , katip - , random + , random , text , trace-dispatcher , time