Configuration examples

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

@@ -9,7 +9,7 @@ import           Control.Monad.IO.Class (MonadIO, liftIO)
 import qualified Control.Tracer as T
 import           Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import qualified Data.Map as Map
-import           Data.Maybe (catMaybes)
+import           Data.Maybe (catMaybes, mapMaybe, fromMaybe)
 import           Katip (Severity)
 
 import           Cardano.Logging.Trace (filterTraceByPrivacy,
@@ -88,9 +88,7 @@ withConfig extract needsConfigFunc tr = do
 -- | If no severity can be found in the config, it is set to Warning
 getSeverity :: TraceConfig -> Context -> SeverityF
 getSeverity config context =
-    case getOption severitySelector config context of
-      Just s  -> s
-      Nothing -> WarningF
+    fromMaybe WarningF (getOption severitySelector config context)
   where
     severitySelector :: ConfigOption -> Maybe SeverityF
     severitySelector (CoSeverity s) = Just s
@@ -99,25 +97,23 @@ getSeverity config context =
 -- | If no privacy can be found in the config, it is set to Public
 getPrivacy :: TraceConfig -> Context -> Privacy
 getPrivacy config context =
-  case getOption privacySelector config context of
-    Just s  -> s
-    Nothing -> Public
+  fromMaybe Public (getOption privacySelector config context)
   where
     privacySelector :: ConfigOption -> Maybe Privacy
     privacySelector (CoPrivacy s) = Just s
     privacySelector _             = Nothing
 
 -- | Searches in the config to find an option
-getOption :: (ConfigOption -> Maybe a) -> TraceConfig -> Context -> (Maybe a)
+getOption :: (ConfigOption -> Maybe a) -> TraceConfig -> Context -> Maybe a
 getOption sel config [] =
-  case (Map.lookup [] (tcOptions config)) of
+  case Map.lookup [] (tcOptions config) of
     Nothing -> Nothing
-    Just options -> case catMaybes (map sel options) of
+    Just options -> case mapMaybe sel options of
                       []        -> Nothing
                       (opt : _) -> Just opt
 getOption sel config context =
-  case (Map.lookup context (tcOptions config)) of
+  case Map.lookup context (tcOptions config) of
     Nothing -> getOption sel config (tail context)
-    Just options -> case catMaybes (map sel options) of
-                      []        -> getOption sel config (tail context)
+    Just options -> case mapMaybe sel options of
+                      []        -> getOption sel config (init context)
                       (opt : _) -> Just opt

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

@@ -1,9 +1,12 @@
 {-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+
 
 module Cardano.Logging.Trace where
 
+import           Control.Arrow
 import           Control.Monad (join)
 import           Control.Monad.IO.Class (MonadIO, liftIO)
 import qualified Control.Tracer as T
@@ -16,6 +19,9 @@ import           Katip (Severity (..))
 
 import           Cardano.Logging.Types
 
+-- | Adds a message object to a trace
+traceWith :: Monad m => Trace m a -> a -> m ()
+traceWith tr a = T.traceWith tr (emptyLoggingContext, Right a)
 
 configureTracers :: Monad m => TraceConfig -> [Trace m a] -> m ()
 configureTracers config tracers = do
@@ -26,11 +32,6 @@ configureTracers config tracers = do
     configureTrace :: Monad m => TraceControl -> Trace m a -> m ()
     configureTrace c tr = T.traceWith tr (emptyLoggingContext, Left c)
 
--- | Adds a message object to a trace
-traceWith :: Monad m => Trace m a -> a -> m ()
-traceWith tr a = T.traceWith tr (emptyLoggingContext, Right a)
-
-
 --- | Don't process further if the result of the selector function
 ---   is False.
 filterTrace :: (Monad m) =>
@@ -96,10 +97,10 @@ setPrivacy p = T.contramap
                     then (lc,v)
                     else (lc {lcPrivacy = Just p}, v))
 
+
 -- | Folds the cata function with acc over a.
 -- Uses an IORef to store the state
--- TODO: Build a foldTrace which uses something like an ArrowLoop for keeping
--- the state without using an IORef
+
 foldTraceM
   :: forall a acc m . MonadIO m
   => (acc -> a -> acc)

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

@@ -66,8 +66,10 @@ data ConfigOption =
   | CoMaxFrequency Int
 
 data TraceConfig = TraceConfig {
+    tcName :: Text
+
      -- | Options specific to a certain namespace
-     tcOptions        :: Map.Map Context [ConfigOption]
+  , tcOptions :: Map.Map Context [ConfigOption]
 
   --  Forwarder:
      -- Can their only be one forwarder? Use one of:
@@ -93,7 +95,7 @@ data TraceConfig = TraceConfig {
 --  ,  tcBindAddrPrometheus :: Maybe (String,Int)
 }
 
-emptyTraceConfig = TraceConfig {tcOptions = Map.empty}
+emptyTraceConfig = TraceConfig {tcName = "", tcOptions = Map.empty}
 
 -- | When configuring a net of tracers, it should be run with Config on all
 -- entry points first, and then with Optimize. When reconfiguring it needs to

trace-dispatcher/test/Examples/Configuration.hs

@@ -0,0 +1,86 @@
+module Examples.Configuration where
+
+import           Control.Monad (liftM)
+import           Control.Monad.IO.Class
+import           Katip
+import           Katip.Scribes.Handle (ioLogEnv)
+import qualified Data.Map as Map
+import           Data.Text (Text)
+
+import           Cardano.Logging
+import           Examples.TestObjects
+
+tracer1 :: MonadIO m => m (Trace m LO)
+tracer1  = fmap
+            (appendName "tracer1")
+            (filterSeverityFromConfig =<< stdoutJsonKatipTracer)
+
+tracer2 :: MonadIO m => m (Trace m LO)
+tracer2  = fmap
+            (appendName "tracer2")
+            (filterSeverityFromConfig =<< stdoutObjectKatipTracer)
+
+config1 :: TraceConfig
+config1 = TraceConfig {
+    tcName = "Config1"
+  , tcOptions = Map.fromList
+          [([], [CoSeverity SilenceF]),
+          (["tracer1"], [CoSeverity ErrorF]),
+          (["tracer2"], [CoSeverity CriticalF]),
+          (["tracer2","bubble"], [CoSeverity InfoF])]
+    }
+
+config2 :: TraceConfig
+config2 = TraceConfig {
+    tcName = "Config2"
+  , tcOptions = Map.fromList [([], [CoSeverity InfoF]),
+          (["tracer2"], [CoSeverity WarningF]),
+          (["tracer2","bubble"], [CoSeverity WarningF])]
+    }
+
+testConfig' :: TraceConfig -> IO ()
+testConfig' tc = do
+    t1 <- tracer1
+    t2 <- tracer2
+    let bubbleTracer = appendName "bubble" t2
+    configureTracers tc [t1, t2, bubbleTracer]
+    traceWith (setSeverity CriticalS t1) (LO2 "Now setting config")
+    traceWith
+      (setSeverity ErrorS t1)
+      (LO2 "1: show with config1 and config2")
+    traceWith
+      (setSeverity InfoS t1)
+      (LO2 "2: show not with config1 but with config2")
+    traceWith
+      (setSeverity NoticeS bubbleTracer)
+      (LO2 "3: show with config1 but not with config2")
+    traceWith
+      (setSeverity WarningS t2)
+      (LO2 "4: show not with config1 but with config2")
+    traceWith
+      (setSeverity InfoS t2)
+      (LO2 "5: never show")
+
+testConfig = do
+  t1 <- tracer1
+  testConfig' config1
+  testConfig' config2
+
+{-
+>>> config1
+{"at":"2021-02-16T14:15:15.351679768Z","env":"io","ns":["io","tracer1"],"data":{"tag":"LO2","comment":"Now setting config"},"app":["io"],"msg":"","pid":"5127","loc":null,"host":"yupanqui-PC","sev":"Critical","thread":"126"}
+
+{"at":"2021-02-16T14:15:15.351679768Z","env":"io","ns":["io","tracer1"],"data":{"tag":"LO2","comment":"1: show with config1 and config2"},"app":["io"],"msg":"","pid":"5127","loc":null,"host":"yupanqui-PC","sev":"Error","thread":"126"}
+
+[2021-02-16 14:15:15][io.tracer2.bubble][Notice][yupanqui-PC][PID 5127][ThreadId 126][tag:LO2][comment:3: show with config1 but not with config2]
+
+>>> config2
+{"at":"2021-02-16T14:15:15.352147647Z","env":"io","ns":["io","tracer1"],"data":{"tag":"LO2","comment":"Now setting config"},"app":["io"],"msg":"","pid":"5127","loc":null,"host":"yupanqui-PC","sev":"Critical","thread":"126"}
+
+{"at":"2021-02-16T14:15:15.352147647Z","env":"io","ns":["io","tracer1"],"data":{"tag":"LO2","comment":"1: show with config1 and config2"},"app":["io"],"msg":"","pid":"5127","loc":null,"host":"yupanqui-PC","sev":"Error","thread":"126"}
+
+{"at":"2021-02-16T14:15:15.352147647Z","env":"io","ns":["io","tracer1"],"data":{"tag":"LO2","comment":"2: show not with config1 but with config2"},"app":["io"],"msg":"","pid":"5127","loc":null,"host":"yupanqui-PC","sev":"Info","thread":"126"}
+
+[2021-02-16 14:15:15][io.tracer2][Warning][yupanqui-PC][PID 5127][ThreadId 126][tag:LO2][comment:4: show not with config1 but with config2]
+
+-}

trace-dispatcher/test/Examples/Trivial.hs

@@ -1,6 +1,4 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-
-
 module Examples.Trivial where
 
 import           Katip

trace-dispatcher/test/Main.hs

@@ -4,6 +4,8 @@ import           Examples.Aggregation
 import           Examples.EKG
 import           Examples.Routing
 import           Examples.Trivial
+import           Examples.Configuration
+import           Cardano.Logging
 
 
 
@@ -13,4 +15,5 @@ main = do
     test2
     testAggregation
     testRouting
-    testEKG
+    testConfig
+--    testEKG

trace-dispatcher/trace-dispatcher.cabal

@@ -42,6 +42,7 @@ executable trace-dispatcher-examples
                       Examples.Trivial
                       Examples.Routing
                       Examples.EKG
+                      Examples.Configuration
     hs-source-dirs:   test
     default-language: Haskell2010
     default-extensions:  OverloadedStrings