With compiling examples

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

@@ -21,15 +21,18 @@ import           Cardano.Logging.Trace (filterTraceByPrivacy,
 import           Cardano.Logging.Types
 
 -- | Call this function at initialisation, and later for reconfiguration
-configureTracers :: Monad m => TraceConfig -> [Trace m a] -> [a] -> m ()
-configureTracers config tracers objects = do
+configureTracers :: Monad m => TraceConfig -> Documented a -> [Trace m a]-> m ()
+configureTracers config (Documented documented) tracers = do
     mapM_ (configureTrace Reset) tracers
     mapM_ (configureAllTrace (Config config)) tracers
     mapM_ (configureTrace Optimize) tracers
   where
-    configureTrace c (Trace tr) = T.traceWith tr (emptyLoggingContext, Just c, head objects)
+    configureTrace c (Trace tr) =
+      T.traceWith tr (emptyLoggingContext, Just c, fst (head documented))
     configureAllTrace c (Trace tr) =
-      mapM (\ m -> T.traceWith tr (emptyLoggingContext, Just c, m)) objects
+      mapM
+        ((\ m -> T.traceWith tr (emptyLoggingContext, Just c, m)) . fst)
+        documented
 
 -- | Take a selector function, and a function from trace to trace with
 --   this selector to make a trace transformer with a config value

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

@@ -25,15 +25,12 @@ import           GHC.Generics
 class LogFormatting a where
   -- | Machine readable representation with the possibility to represent
   -- with different details based on the detail level.
-  -- Falls back to ToJson of Aeson in the default representation
+  -- No machine readable representation as default
   forMachine :: DetailLevel -> a -> A.Object
-  default forMachine :: A.ToJSON a => DetailLevel -> a -> A.Object
-  forMachine _ v = case A.toJSON v of
-    A.Object o     -> o
-    s@(A.String _) -> HM.singleton "string" s
-    _              -> mempty
+  forMachine _ v = mempty
 
   -- | Human readable representation.
+  -- No human representation is represented by the empty text and is the default
   forHuman :: a -> Text
   forHuman v = ""
 
@@ -42,30 +39,25 @@ class LogFormatting a where
   asMetrics :: a -> [Metric]
   asMetrics v = []
 
--- -- ||| Alternatively:
--- data LogFormatter a = LogFormatter {
---     -- | Machine readable representation with the possibility of representation
---     -- with different detail levels.
---     -- Can use ToJson of Aeson as default
---     machineRep :: DetailLevel -> a -> A.Object
---   , -- | Human readable representation.
---     -- An empty String represents no representation
---     humanRep   :: a -> Text
---   , -- | Metrics representation.
---     -- May be empty, meaning no metrics
---     metricsRep :: a -> [Metric]
--- }
-
 data Metric
   -- | An integer metric.
   -- If a text is given it is appended as last element to the namespace
     = IntM (Maybe Text) Integer
   -- | A double metric.
   -- If a text is given it is appended as last element to the namespace
     | DoubleM (Maybe Text) Double
-  deriving (Show, Eq, Generic)
+  deriving (Show, Eq)
+
+-- Document all log messages by providing a list of (prototye, documentation) pairs
+-- for all constructors. Because it is not enforced by the type system, it is very
+-- important to provide a complete list, as the prototypes are used as well for documentation.
+-- If you don't want to add an item for documentation enter an empty text.
+newtype Documented a = Documented [(a,Text)]
+
+-------------------------------------------------------------------
 
 type Namespace = [Text]
+
 type Selector  = [Text]
 
 -- | Context of a message
@@ -74,16 +66,18 @@ data LoggingContext = LoggingContext {
   , lcSeverity :: Maybe SeverityS
   , lcPrivacy  :: Maybe Privacy
   , lcDetails  :: Maybe DetailLevel
-  }
-  deriving (Eq, Show, Generic)
+  } deriving (Eq, Show)
+
+emptyLoggingContext :: LoggingContext
+emptyLoggingContext = LoggingContext [] Nothing Nothing Nothing
 
 -- | Tracer comes from the contra-tracer package and carries a context and maybe a trace
 -- control object
-newtype Trace m a = Trace {unpackTrace :: Tracer m (LoggingContext, Maybe TraceControl, a)}
+newtype Trace m a = Trace
+  {unpackTrace :: Tracer m (LoggingContext, Maybe TraceControl, a)}
 
 -- | Contramap lifted to Trace
 instance Monad m => Contravariant (Trace m) where
---  contravariant :: Monad m => (a -> b) -> Trace m b -> Trace m a
     contramap f (Trace tr) = Trace $
       T.contramap (\ (lc, mbC, a) -> (lc, mbC, f a)) tr
 
@@ -95,9 +89,6 @@ instance Monad m => Monoid (Trace m a) where
     mappend = (<>)
     mempty  = Trace T.nullTracer
 
-emptyLoggingContext :: LoggingContext
-emptyLoggingContext = LoggingContext [] Nothing Nothing Nothing
-
 -- | Formerly known as verbosity
 data DetailLevel = DBrief | DRegular | DDetailed
   deriving (Show, Eq, Ord, Bounded, Enum, Generic)
@@ -183,13 +174,7 @@ data TraceControl where
     Config :: TraceConfig -> TraceControl
     Optimize :: TraceControl
     Document :: DocCollector -> TraceControl
-  deriving(Eq, Show, Generic)
-
--- Document all log messages by providing a list of (prototye, documentation) pairs
--- for all constructors. Because it is not enforced by the type system, it is very
--- important to provide a complete list, as the prototypes are used as well for documentation.
--- If you don't want to add an item for documentation enter an empty text.
-newtype Documented a = Documented [(a,Text)]
+  deriving(Eq, Show)
 
 data DocCollector = DocCollector {
     cDoc       :: Text
@@ -198,10 +183,10 @@ data DocCollector = DocCollector {
   , cPrivacy   :: [Privacy]
   , cDetails   :: [DetailLevel]
   , cBackends  :: [Backend]
-  , ccSeverity :: [SeverityS]
+  , ccSeverity :: [SeverityF]
   , ccPrivacy  :: [Privacy]
   , ccDetails  :: [DetailLevel]
-} deriving(Eq, Show, Generic)
+} deriving(Eq, Show)
 
 emptyCollector :: DocCollector
 emptyCollector = DocCollector "" [] [] [] [] [] [] [] []
@@ -219,21 +204,6 @@ instance LogFormatting b => LogFormatting (Folding a b) where
   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 TraceControl where
-    toEncoding = A.genericToEncoding A.defaultOptions
-
-instance A.ToJSON DocCollector where
-    toEncoding = A.genericToEncoding A.defaultOptions
-
-instance A.ToJSON Backend where
-    toEncoding = A.genericToEncoding A.defaultOptions
-
 instance A.ToJSON DetailLevel where
     toEncoding = A.genericToEncoding A.defaultOptions
 

trace-dispatcher/test/Examples/Aggregation.hs

@@ -25,11 +25,15 @@ data BaseStats = BaseStats {
 instance A.ToJSON BaseStats where
     toEncoding = A.genericToEncoding A.defaultOptions
 
-instance Logging BaseStats where
+instance LogFormatting BaseStats where
   asMetrics BaseStats {..} =
     [ DoubleM (Just "measure") bsMeasure
     , DoubleM (Just "sum") bsSum]
 
+baseStatsDocumented :: Documented Double
+baseStatsDocumented =
+  Documented [(0.0,"Measure"), (0.0,"Sum")]
+
 emptyStats :: BaseStats
 emptyStats = BaseStats 0.0 100000000.0 (-100000000.0) 0 0.0
 
@@ -45,7 +49,7 @@ testAggregation :: IO ()
 testAggregation = do
     simpleTracer  <- stdoutObjectKatipTracer
     tracer <- foldTraceM calculate emptyStats simpleTracer
-    configureTracers emptyTraceConfig [tracer]
+    configureTracers emptyTraceConfig baseStatsDocumented [tracer]
     traceWith tracer 1.0
     traceWith tracer 2.0
     traceWith tracer 0.5

trace-dispatcher/test/Examples/Configuration.hs

@@ -2,6 +2,8 @@ module Examples.Configuration where
 
 import           Control.Monad (liftM)
 import           Control.Monad.IO.Class
+import qualified Data.Aeson as AE
+import qualified Data.HashMap.Strict as HM
 import qualified Data.Map as Map
 import           Data.Text (Text)
 import           Katip
@@ -10,12 +12,27 @@ import           Katip.Scribes.Handle (ioLogEnv)
 import           Cardano.Logging
 import           Examples.TestObjects
 
-tracer1 :: MonadIO m => m (Trace m LO)
+newtype TestMessage = TestMessage Text
+  deriving Show
+
+instance LogFormatting TestMessage where
+  forHuman (TestMessage text)         = text
+  forMachine _verb (TestMessage text) =
+         HM.fromList
+           [ "kind" AE..= AE.String "TestMessage"
+           , "text" AE..= AE.String text
+           ]
+
+testMessageDocumented = Documented [
+  (TestMessage "dummy", "just a text")
+  ]
+
+tracer1 :: MonadIO m => m (Trace m TestMessage)
 tracer1  = fmap
             (appendName "tracer1")
             (filterSeverityFromConfig =<< stdoutJsonKatipTracer)
 
-tracer2 :: MonadIO m => m (Trace m LO)
+tracer2 :: MonadIO m => m (Trace m TestMessage)
 tracer2  = fmap
             (appendName "tracer2")
             (filterSeverityFromConfig =<< stdoutObjectKatipTracer)
@@ -41,23 +58,23 @@ testConfig' tc = do
     t1 <- tracer1
     t2 <- tracer2
     let bubbleTracer = appendName "bubble" t2
-    configureTracers tc [t1, t2, bubbleTracer]
-    traceWith (setSeverity Critical t1) (LO2 "Now setting config")
+    configureTracers tc testMessageDocumented [t1, t2, bubbleTracer]
+    traceWith (setSeverity Critical t1) (TestMessage "Now setting config")
     traceWith
       (setSeverity Error t1)
-      (LO2 "1: show with config1 and config2")
+      (TestMessage "1: show with config1 and config2")
     traceWith
       (setSeverity Info t1)
-      (LO2 "2: show not with config1 but with config2")
+      (TestMessage "2: show not with config1 but with config2")
     traceWith
       (setSeverity Notice bubbleTracer)
-      (LO2 "3: show with config1 but not with config2")
+      (TestMessage "3: show with config1 but not with config2")
     traceWith
       (setSeverity Warning t2)
-      (LO2 "4: show not with config1 but with config2")
+      (TestMessage "4: show not with config1 but with config2")
     traceWith
       (setSeverity Info t2)
-      (LO2 "5: never show")
+      (TestMessage "5: never show")
 
 testConfig = do
   t1 <- tracer1

trace-dispatcher/test/Examples/EKG.hs

@@ -6,13 +6,17 @@ import           Control.Monad (liftM)
 import           Data.Text (pack)
 import           System.Remote.Monitoring (forkServer)
 
-instance Logging Int where
-  asMetrics i = [IntM Nothing i]
+instance LogFormatting Int where
+  asMetrics i = [IntM Nothing (fromIntegral i)]
+
+countDocumented :: Documented Int
+countDocumented = Documented [(0,"count")]
 
 testEKG :: IO ()
 testEKG = do
     server <- forkServer "localhost" 8000
     tracer <- ekgTracer (Right server)
+    configureTracers emptyTraceConfig countDocumented [tracer]
     loop (appendName "ekg1" tracer) 1
   where
     loop :: Trace IO Int -> Int -> IO ()

trace-dispatcher/test/Examples/FrequencyLimiting.hs

@@ -10,28 +10,29 @@ import           Control.Monad.IO.Class
 import           Control.Monad.IO.Unlift
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Types as A
+import           Data.Functor.Contravariant (Contravariant (..))
 import           GHC.Generics
 
 import           Cardano.Logging
 import           Examples.TestObjects
 
-data LOX = LOS LO | LOL LimitingMessage
- deriving (Logging, Generic, A.ToJSON)
+data LOX = LOS (TraceForgeEvent LogBlock) | LOL LimitingMessage
+ deriving (LogFormatting, Generic)
 
-tracer1 :: (MonadIO m, MonadUnliftIO m) => m (Trace m LO)
+tracer1 :: (MonadIO m, MonadUnliftIO m) => m (Trace m (TraceForgeEvent LogBlock))
 tracer1  = do
   t1      <- fmap (appendName "tracer1") stdoutObjectKatipTracer
-  limitFrequency 5 "5 messages per second" (cmap LOS t1) (cmap LOL t1)
+  limitFrequency 5 "5 messages per second" (contramap LOS t1) (contramap LOL t1)
 
-tracer2 :: (MonadIO m, MonadUnliftIO m) => m (Trace m LO)
+tracer2 :: (MonadIO m, MonadUnliftIO m) => m (Trace m (TraceForgeEvent LogBlock))
 tracer2  = do
   t2      <- fmap (appendName "tracer2") stdoutJsonKatipTracer
-  limitFrequency 15 "15 messages per second" (cmap LOS t2) (cmap LOL t2)
+  limitFrequency 15 "15 messages per second" (contramap LOS t2) (contramap LOL t2)
 
-repeated :: Trace IO LO -> Int -> Int -> IO ()
+repeated :: Trace IO (TraceForgeEvent LogBlock) -> Int -> Int -> IO ()
 repeated _ 0 _ = pure ()
 repeated t n d = do
-  traceWith t (LO1 n)
+  traceWith t (TraceStartLeadershipCheck (SlotNo (fromIntegral n)))
   threadDelay d
   repeated t (n-1) d
 

trace-dispatcher/test/Examples/Routing.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 module Examples.Routing where
 
 import           Control.Monad (liftM)
@@ -8,31 +9,33 @@ import           Katip.Scribes.Handle (ioLogEnv)
 import           Cardano.Logging
 import           Examples.TestObjects
 
-tracer1 :: MonadIO m => m (Trace m LO)
-tracer1  = liftM (appendName "tracer1") stdoutObjectKatipTracer
+tracer1 :: (LogFormatting (TraceForgeEvent blk), MonadIO m) =>
+  m (Trace m (TraceForgeEvent blk))
+tracer1  = fmap (appendName "tracer1") stdoutObjectKatipTracer
 
-tracer2 :: MonadIO m => m (Trace m LO)
-tracer2  = liftM (appendName "tracer2") stdoutJsonKatipTracer
+tracer2 :: (LogFormatting (TraceForgeEvent blk), MonadIO m) =>
+  m (Trace m (TraceForgeEvent blk))
+tracer2  = fmap (appendName "tracer2") stdoutJsonKatipTracer
 
 routingTracer1 :: (Monad m)
-  => Trace m LO
-  -> Trace m LO
-  -> Trace m LO
+  => Trace m (TraceForgeEvent LogBlock)
+  -> Trace m (TraceForgeEvent LogBlock)
+  -> Trace m (TraceForgeEvent LogBlock)
 routingTracer1 t1 t2 = routingTrace routingf (t1 <> t2)
   where
-    routingf LO1 {} = t1
-    routingf LO2 {} = t2
+    routingf TraceStartLeadershipCheck {} = t1
+    routingf _                            = t2
 
 routingTracer2 :: (Monad m)
-  => Trace m LO
-  -> Trace m LO
-  -> Trace m LO
+  => Trace m (TraceForgeEvent LogBlock)
+  -> Trace m (TraceForgeEvent LogBlock)
+  -> Trace m (TraceForgeEvent LogBlock)
 routingTracer2 t1 t2 = t1 <> t2
 
 testRouting :: IO ()
 testRouting = do
     t1 <- tracer1
     t2 <- tracer2
-    traceWith (routingTracer1 t1 t2) logObject1
-    traceWith (routingTracer1 t1 t2) logObject2
-    traceWith (t1 <> t2) logObject3
+    traceWith (routingTracer1 t1 t2) message1
+    traceWith (routingTracer1 t1 t2) message2
+    traceWith (t1 <> t2) message3