trace-dispatcher library

cabal.project

@@ -13,7 +13,9 @@ packages:
     bench/locli
     bench/tx-generator
     plutus-example/plutus-example
+    trace-dispatcher
     trace-forward
+    trace-resources
 
 package cardano-api
   ghc-options: -Werror
@@ -33,6 +35,12 @@ package cardano-node-chairman
 package tx-generator
   ghc-options: -Werror
 
+package trace-dispatcher
+  ghc-options: -Werror
+
+package trace-resources
+  ghc-options: -Werror
+
 package cryptonite
   -- Using RDRAND instead of /dev/urandom as an entropy source for key
   -- generation is dubious. Set the flag so we use /dev/urandom by default.
@@ -65,6 +73,12 @@ package cardano-submit-api
 package cardano-testnet
   tests: True
 
+package trace-resources
+  tests: True
+
+package trace-dispatcher
+  tests: True
+
 package trace-forward
   tests: True
 
@@ -246,6 +260,12 @@ source-repository-package
     stubs/plutus-ghc-stub
     word-array
 
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/ekg-forward
+  tag: d3e8a3abe2b55e72aca79212b053b4aabade91f4
+  --sha256: 04gwrmkkq0ami6qff0vsi8i5m4qan6pv7jj76k2b88qhk0407wyj
+
 -- Drops an instance breaking our code. Should be released to Hackage eventually.
 source-repository-package
   type: git

trace-dispatcher/.gitignore

@@ -0,0 +1,11 @@
+.cabal-sandbox
+dist
+cabal.sandbox.config
+TAGS
+.stack-work/
+*.o
+*.hi
+*.dyn_o
+*.dyn_hi
+stack.yaml.lock
+*.pdf

trace-dispatcher/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for trace-dispatcher
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

trace-dispatcher/README.md

@@ -0,0 +1,7 @@
+trace-dispatcher
+
+We integrated contra-tracer-0.1.0.0 into the source tree, because the
+iohk-monitoring framework depends on the non-arrow based contra-tracer framework.
+This should become a dependency later.
+
+The documentation can currently be found under: docs/trace-dispatcher.md  

trace-dispatcher/examples/Examples/Aggregation.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+
+module Examples.Aggregation (
+  testAggregation
+) where
+
+import qualified Data.Aeson as A
+import           GHC.Generics (Generic)
+
+import           Cardano.Logging
+
+data BaseStats = BaseStats {
+    bsMeasure :: Double,
+    bsMin     :: Double,
+    bsMax     :: Double,
+    bsCount   :: Int,
+    bsSum     :: Double
+    } deriving (Eq, Ord, Show, Generic)
+
+instance A.ToJSON BaseStats where
+  toEncoding = A.genericToEncoding A.defaultOptions
+
+instance LogFormatting BaseStats where
+  forMachine = mempty
+  asMetrics BaseStats {..} =
+    [ DoubleM ["measure"] bsMeasure
+    , DoubleM ["sum"] bsSum]
+
+baseStatsDocumented :: Documented Double
+baseStatsDocumented =
+  Documented
+  [ DocMsg 0.0 [] "This is the value of the measurement"
+  , DocMsg 0.0 [] "This is the sum of all measurments so far"
+  ]
+
+emptyStats :: BaseStats
+emptyStats = BaseStats 0.0 100000000.0 (-100000000.0) 0 0.0
+
+calculate :: BaseStats -> LoggingContext -> Double -> BaseStats
+calculate BaseStats{..} _ val =
+    BaseStats
+      val
+      (min bsMin val)
+      (max bsMax val)
+      (1 + bsCount)
+      (bsSum + val)
+
+testAggregation :: IO ()
+testAggregation = do
+    simpleTracer  <- standardTracer Nothing
+    formTracer <- humanFormatter True "cardano" simpleTracer
+    tracer <- foldTraceM calculate emptyStats formTracer
+    configureTracers emptyTraceConfig baseStatsDocumented [tracer]
+    traceWith tracer 1.0
+    traceWith tracer 2.0
+    traceWith tracer 0.5

trace-dispatcher/examples/Examples/Configuration.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Examples.Configuration (
+    testConfig
+  , testMessageDocumented
+) where
+
+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           Cardano.Logging
+
+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
+testMessageDocumented = Documented
+  [ DocMsg (TestMessage "dummy") [] "just a text"
+  ]
+
+tracers :: MonadIO m => m (Trace m TestMessage, Trace m TestMessage)
+tracers  = do
+  t <- standardTracer Nothing
+  t0 <- humanFormatter True "cardano" t
+  t1 <- appendName "tracer1" <$> filterSeverityFromConfig t0
+  t2 <- appendName "tracer2" <$> filterSeverityFromConfig t0
+  pure (t1, t2)
+
+config1 :: TraceConfig
+config1 = TraceConfig {
+      tcOptions = Map.fromList
+          [ ([], [CoSeverity SilenceF])
+          , (["tracer1"], [CoSeverity ErrorF])
+          , (["tracer2"], [CoSeverity CriticalF])
+          , (["tracer2","bubble"], [CoSeverity InfoF])
+          ]
+    , tcForwarder = LocalSocket "forwarder.log"
+    , tcForwarderQueueSize = 100
+    }
+
+config2 :: TraceConfig
+config2 = TraceConfig {
+      tcOptions = Map.fromList
+        [ ([], [CoSeverity InfoF])
+        , (["tracer2"], [CoSeverity WarningF])
+        , (["tracer2","bubble"], [CoSeverity WarningF])
+        ]
+    , tcForwarder = LocalSocket "forwarder.log"
+    , tcForwarderQueueSize = 100
+    }
+
+testConfig' :: MonadIO m => TraceConfig -> Trace m TestMessage -> Trace m TestMessage -> m ()
+testConfig' tc t1 t2 = do
+    let bubbleTracer = appendName "bubble" t2
+    configureTracers tc testMessageDocumented [t1, t2]
+    traceWith (setSeverity Critical t1) (TestMessage "Now setting config")
+    traceWith
+      (setSeverity Error t1)
+      (TestMessage "1: show with config1 and config2")
+    traceWith
+      (setSeverity Info t1)
+      (TestMessage "2: show not with config1 but with config2")
+    traceWith
+      (setSeverity Notice bubbleTracer)
+      (TestMessage "3: show with config1 but not with config2")
+    traceWith
+      (setSeverity Warning t2)
+      (TestMessage "4: show not with config1 but with config2")
+    traceWith
+      (setSeverity Info t2)
+      (TestMessage "5: never show")
+
+testConfig :: IO ()
+testConfig = do
+  (t1, t2) <- tracers
+  testConfig' config1 t1 t2
+  testConfig' config2 t1 t2

trace-dispatcher/examples/Examples/Documentation.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Examples.Documentation (
+  docTracers
+) where
+
+import qualified Data.Text.IO as T
+
+import           Cardano.Logging
+import           Examples.TestObjects
+
+docTracers :: IO ()
+docTracers = do
+  t <- standardTracer Nothing
+  t1' <- humanFormatter True "cardano" t
+  let t1 = withSeverityTraceForgeEvent
+                (appendName "node" t1')
+  t2' <- machineFormatter "cardano" t
+  let t2 = withSeverityTraceForgeEvent
+                (appendName "node" t2')
+  bl <- documentMarkdown traceForgeEventDocu [t1, t2]
+  res <- buildersToText bl emptyTraceConfig
+  T.writeFile "/home/yupanqui/IOHK/Testdocu.md" res

trace-dispatcher/examples/Examples/EKG.hs

@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -Wno-orphans  #-}
+
+module Examples.EKG (
+  testEKG
+) where
+
+import           Cardano.Logging
+import           Control.Concurrent
+import           System.Remote.Monitoring (forkServer)
+
+
+countDocumented :: Documented Int
+countDocumented = Documented [DocMsg 0 [] "count"]
+
+testEKG :: IO ()
+testEKG = do
+    server <- forkServer "localhost" 8000
+    tracer <- ekgTracer (Right server)
+    formattedTracer <- metricsFormatter "cardano" tracer
+    configureTracers emptyTraceConfig countDocumented [formattedTracer]
+    loop (appendName "ekg1" formattedTracer) 1
+  where
+    loop :: Trace IO Int -> Int -> IO ()
+    loop tr count = do
+      if count == 1000
+        then pure ()
+        else do
+          traceWith (appendName "count" tr) count
+          threadDelay 100000
+          loop tr (count + 1)

trace-dispatcher/examples/Examples/FrequencyLimiting.hs

@@ -0,0 +1,48 @@
+module Examples.FrequencyLimiting (
+  testLimiting
+) where
+
+import           Control.Concurrent
+import           Data.Aeson
+
+import           Cardano.Logging
+import           Examples.TestObjects
+
+data LOX = LOS (TraceForgeEvent LogBlock) | LOL LimitingMessage
+
+instance LogFormatting LOX where
+  forMachine _ (LOS _) =
+      mkObject
+        [ "kind" .= String "TraceForgeEvent"
+        ]
+  forMachine _ (LOL (StartLimiting text)) =
+      mkObject
+        [ "kind" .= String "StartLimiting"
+        , "msg"  .= String text
+        ]
+  forMachine _ (LOL (StopLimiting msg num)) =
+      mkObject
+        [ "kind" .= String "StopLimiting"
+        , "msg"  .= String msg
+        , "numSuppressed" .= num
+        ]
+
+repeated :: Trace IO (TraceForgeEvent LogBlock) -> Int -> Int -> IO ()
+repeated _ 0 _ = pure ()
+repeated t n d = do
+  traceWith t (TraceStartLeadershipCheck (SlotNo (fromIntegral n)))
+  threadDelay d
+  repeated t (n-1) d
+
+testLimiting :: IO ()
+testLimiting = do
+  t0 <- standardTracer Nothing
+  tf <- humanFormatter True "cardano" t0
+  t1 <- (\tt -> limitFrequency 5 "5 messages per second" (contramap LOS tt) (contramap LOL tt))
+              (appendName "tracer1" tf)
+  t2 <- (\tt -> limitFrequency 15 "15 messages per second" (contramap LOS tt) (contramap LOL tt))
+              (appendName "tracer2" tf)
+  let t = t1 <> t2
+  repeated t 1000 10000 -- 100 messages per second
+  repeated t 20 1000000 -- 1  message per second
+  repeated t 300 100000 -- 10  message per second

trace-dispatcher/examples/Examples/Routing.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Examples.Routing (
+  testRouting
+) where
+
+import           Cardano.Logging
+import           Examples.TestObjects
+
+routingTracer1 :: (Monad m)
+  => Trace m (TraceForgeEvent LogBlock)
+  -> Trace m (TraceForgeEvent LogBlock)
+  -> m (Trace m (TraceForgeEvent LogBlock))
+routingTracer1 t1 t2 = routingTrace routingf (t1 <> t2)
+  where
+    routingf TraceStartLeadershipCheck {} = pure t1
+    routingf _                            = pure t2
+
+routingTracer2 :: (Monad m)
+  => Trace m (TraceForgeEvent LogBlock)
+  -> Trace m (TraceForgeEvent LogBlock)
+  -> m (Trace m (TraceForgeEvent LogBlock))
+routingTracer2 t1 t2 = pure (t1 <> t2)
+
+testRouting :: IO ()
+testRouting = do
+    t <- standardTracer Nothing
+    tf <- machineFormatter "cardano" t
+    let t1 = appendName "tracer1" tf
+    let t2 = appendName "tracer1" tf
+    configureTracers emptyTraceConfig traceForgeEventDocu [t1, t2]
+    r1 <- routingTracer1 t1 t2
+    r2 <- routingTracer2 t1 t2
+    traceWith r1 message2
+    traceWith r2 message2
+    traceWith (t1 <> t2) message3