From f25302c2de8c085dd8f3c0242fe23dbd3464009b Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Thu, 12 Aug 2021 14:37:12 +0400 Subject: [PATCH 01/12] trace-dispatcher library --- cabal.project | 20 + trace-dispatcher/.gitignore | 11 + trace-dispatcher/CHANGELOG.md | 5 + trace-dispatcher/README.md | 7 + trace-dispatcher/doc/trace-dispatcher.md | 798 ++++++++++++++++++ .../examples/Examples/Aggregation.hs | 60 ++ .../examples/Examples/Configuration.hs | 88 ++ .../examples/Examples/Documentation.hs | 22 + trace-dispatcher/examples/Examples/EKG.hs | 30 + .../examples/Examples/FrequencyLimiting.hs | 48 ++ trace-dispatcher/examples/Examples/Routing.hs | 36 + .../examples/Examples/TestObjects.hs | 212 +++++ trace-dispatcher/examples/Examples/Trivial.hs | 49 ++ trace-dispatcher/examples/Main.hs | 22 + trace-dispatcher/examples/config.json | 49 ++ trace-dispatcher/examples/config.nix | 18 + trace-dispatcher/src/Cardano/Logging.hs | 15 + .../src/Cardano/Logging/Configuration.hs | 484 +++++++++++ .../src/Cardano/Logging/DocuGenerator.hs | 335 ++++++++ .../src/Cardano/Logging/Formatter.hs | 262 ++++++ .../src/Cardano/Logging/FrequencyLimiter.hs | 190 +++++ trace-dispatcher/src/Cardano/Logging/Trace.hs | 261 ++++++ .../src/Cardano/Logging/Tracer/Composed.hs | 120 +++ .../src/Cardano/Logging/Tracer/EKG.hs | 84 ++ .../src/Cardano/Logging/Tracer/Forward.hs | 208 +++++ .../src/Cardano/Logging/Tracer/Standard.hs | 94 +++ trace-dispatcher/src/Cardano/Logging/Types.hs | 346 ++++++++ trace-dispatcher/src/Control/Tracer.hs | 240 ++++++ trace-dispatcher/src/Control/Tracer/Arrow.hs | 90 ++ .../test/Cardano/Logging/Test/Config.hs | 46 + .../test/Cardano/Logging/Test/Messages.hs | 54 ++ .../test/Cardano/Logging/Test/Oracles.hs | 113 +++ .../test/Cardano/Logging/Test/Script.hs | 166 ++++ .../test/Cardano/Logging/Test/Tracer.hs | 20 + .../test/Cardano/Logging/Test/Types.hs | 92 ++ .../test/trace-dispatcher-test.hs | 21 + trace-dispatcher/trace-dispatcher.cabal | 151 ++++ trace-resources/.gitignore | 11 + trace-resources/CHANGELOG.md | 5 + trace-resources/README.md | 3 + .../src/Cardano/Logging/Resources.hs | 23 + .../src/Cardano/Logging/Resources/Darwin.hsc | 114 +++ .../src/Cardano/Logging/Resources/Dummy.hs | 33 + .../src/Cardano/Logging/Resources/Linux.hs | 57 ++ .../src/Cardano/Logging/Resources/Types.hs | 79 ++ .../src/Cardano/Logging/Resources/Windows.hsc | 177 ++++ .../Logging/Resources/os-support-darwin.c | 272 ++++++ .../Logging/Resources/os-support-darwin.h | 37 + .../Logging/Resources/os-support-win.c | 94 +++ .../Logging/Resources/os-support-win.h | 14 + trace-resources/test/trace-resources-test.hs | 60 ++ trace-resources/trace-resources.cabal | 76 ++ 52 files changed, 5922 insertions(+) create mode 100644 trace-dispatcher/.gitignore create mode 100644 trace-dispatcher/CHANGELOG.md create mode 100644 trace-dispatcher/README.md create mode 100644 trace-dispatcher/doc/trace-dispatcher.md create mode 100644 trace-dispatcher/examples/Examples/Aggregation.hs create mode 100644 trace-dispatcher/examples/Examples/Configuration.hs create mode 100644 trace-dispatcher/examples/Examples/Documentation.hs create mode 100644 trace-dispatcher/examples/Examples/EKG.hs create mode 100644 trace-dispatcher/examples/Examples/FrequencyLimiting.hs create mode 100644 trace-dispatcher/examples/Examples/Routing.hs create mode 100644 trace-dispatcher/examples/Examples/TestObjects.hs create mode 100644 trace-dispatcher/examples/Examples/Trivial.hs create mode 100644 trace-dispatcher/examples/Main.hs create mode 100644 trace-dispatcher/examples/config.json create mode 100644 trace-dispatcher/examples/config.nix create mode 100644 trace-dispatcher/src/Cardano/Logging.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/Configuration.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/Formatter.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/Trace.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs create mode 100644 trace-dispatcher/src/Cardano/Logging/Types.hs create mode 100644 trace-dispatcher/src/Control/Tracer.hs create mode 100644 trace-dispatcher/src/Control/Tracer/Arrow.hs create mode 100644 trace-dispatcher/test/Cardano/Logging/Test/Config.hs create mode 100644 trace-dispatcher/test/Cardano/Logging/Test/Messages.hs create mode 100644 trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs create mode 100644 trace-dispatcher/test/Cardano/Logging/Test/Script.hs create mode 100644 trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs create mode 100644 trace-dispatcher/test/Cardano/Logging/Test/Types.hs create mode 100644 trace-dispatcher/test/trace-dispatcher-test.hs create mode 100644 trace-dispatcher/trace-dispatcher.cabal create mode 100644 trace-resources/.gitignore create mode 100644 trace-resources/CHANGELOG.md create mode 100644 trace-resources/README.md create mode 100644 trace-resources/src/Cardano/Logging/Resources.hs create mode 100644 trace-resources/src/Cardano/Logging/Resources/Darwin.hsc create mode 100644 trace-resources/src/Cardano/Logging/Resources/Dummy.hs create mode 100644 trace-resources/src/Cardano/Logging/Resources/Linux.hs create mode 100644 trace-resources/src/Cardano/Logging/Resources/Types.hs create mode 100644 trace-resources/src/Cardano/Logging/Resources/Windows.hsc create mode 100644 trace-resources/src/Cardano/Logging/Resources/os-support-darwin.c create mode 100644 trace-resources/src/Cardano/Logging/Resources/os-support-darwin.h create mode 100644 trace-resources/src/Cardano/Logging/Resources/os-support-win.c create mode 100644 trace-resources/src/Cardano/Logging/Resources/os-support-win.h create mode 100644 trace-resources/test/trace-resources-test.hs create mode 100644 trace-resources/trace-resources.cabal diff --git a/cabal.project b/cabal.project index cef3fad410d..019035a5631 100644 --- a/cabal.project +++ b/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 @@ -249,6 +263,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 diff --git a/trace-dispatcher/.gitignore b/trace-dispatcher/.gitignore new file mode 100644 index 00000000000..e825f8bed1c --- /dev/null +++ b/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 diff --git a/trace-dispatcher/CHANGELOG.md b/trace-dispatcher/CHANGELOG.md new file mode 100644 index 00000000000..9ef8d24bdba --- /dev/null +++ b/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. diff --git a/trace-dispatcher/README.md b/trace-dispatcher/README.md new file mode 100644 index 00000000000..02e1bf05112 --- /dev/null +++ b/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 diff --git a/trace-dispatcher/doc/trace-dispatcher.md b/trace-dispatcher/doc/trace-dispatcher.md new file mode 100644 index 00000000000..cbd4b01a781 --- /dev/null +++ b/trace-dispatcher/doc/trace-dispatcher.md @@ -0,0 +1,798 @@ +# trace-dispatcher: efficient, simple and flexible program tracing + +`trace-dispatcher` is a library that enables definition of __tracing systems__ -- systems that collect and manages traces -- evidence of program execution. + +# Contents + +0. [Contents](#Contents) +1. [Document status](#Document-status) +2. [Introduction](#Introduction) + 1. [Motivation](#motivation) + 2. [Design decisions](#Design-decisions) + 3. [Overview and terminology](#Overview-and-terminology) +3. [Interface overview](#Interface-overview) + 1. [The trace / tracer duality](#The-trace--tracer-duality) + 2. [Emitting traces](#Emitting-traces) + 3. [Tracer namespace](#Tracer-namespace) + 4. [Trace context](#Trace-context) + 5. [Filter context](#Filter-context) + 1. [Severity](#Severity) + 2. [Privacy](#Privacy) + 3. [Frequency](#Frequency) + 6. [Presentation](#Presentation) + 1. [Formatting](#Formatting) + 2. [Detail level](#Detail-level) + 8. [Fold-based aggregation](#Fold-based-aggregation) + 9. [Dispatcher routing toolkit](#Dispatcher-routing-toolkit) + 10. [Configuration](#Configuration) + 11. [Documentation](#Documentation) +4. [Integration and implementation in the node](#Integration-and-implementation-in-the-node) + 1. [Overall tracing setup](#Overall-tracing-setup) + 2. [Trace-outs](#Trace-outs) + 3. [Explicit trace filtering](#Explicit-trace-filtering) + 4. [Confidentiality and privacy filtering implementation](#Confidentiality-and-privacy-filtering-implementation) + 5. [Documentation generation](#Documentation-generation) +5. [Appendix](#Appendix) + 1. [Decisions](#Decisions) + 2. [Future work](#Future-work) + +# Document status + +Work in progress. + +To do list: + +* [x] Finish editing. +* [x] [Decide inline trace type annotation with trace function](#Decide-inline-trace-type-annotation-with-trace-function) +* [x] [Decide tracer definedness](#Decide-tracer-definedness) +* [x] [Decide tracer name definition](#Decide-tracer-name-definition) +* [x] [Decide inline trace type annotation with trace function 2](#Decide-inline-trace-type-annotation-with-trace-function-2) +* [x] [Decide on explicit trace filtering](#Decide-on-explicit-trace-filtering) +* [x] [Decide on privately combinator](#Decide-on-privately-combinator) +* [x] [Decide extra privacy tagging](#Decide-extra-privacy-tagging) +* [x] [Decide on type errors instead of silent dropping of messages](#Decide-on-type-errors-instead-of-silent-dropping-of-messages) +* [ ] [Decide on more direct interface to EKG metrics](#Decide-on-more-direct-interface-to-ekg-metrics) +* [x] [Decide on dispatcher detail level control](#Decide-on-dispatcher-detail-level-control) +* [x] [Decide namespace-aware configuration](#Decide-namespace-aware-configuration) +* [ ] [Discuss impact of missing documentation entries](#Discuss-impact-of-missing-documentation-entries) +* [x] [Decide missing configuration](#Decide-missing-configuration) +* [x] [Decide complete configuration](#Decide-complete-configuration) +* [ ] [Discuss possibility of pure, thread-safe aggregation](#Discuss-possibility-of-pure-thread-safe-aggregation) +* [ ] [Decide trace-outs types](#Decide-trace-outs-types) +* [ ] Agree on editing. +* [ ] Final proofreading. +* [ ] Feedback. + +# Introduction + +## Motivation + +`trace-dispatcher` is an attempt to enable design and implementation of simple, efficient __tracing systems__, one that has a reduced footprint in the executed program, has a more pleasant API, and provides self-documenting features. + +## Design decisions + +Key design decisions were: + +1. Retaining the separation of concerns in the frontend side, as provided by the `contra-tracer` library. The client code should not need to concern itself with any details beyond passing the traces down to the system. +2. Rely on __trace combinators__ primarily, as opposed to opting for a typeclass heavy API. +3. Separation of data plane and control plane: high-frequency events incur minimal processing on the data-plane, whereas complicated configuration logic only happens on the control plane, and that is proportional to infrequent reconfiguration events. +4. A tougher stance on separation of concerns in the backend side: we choose to move expensive trace processing to an external process. +5. A measure of backward compatibility with the previous logging system. +6. Retaining the global namespace for all traces. + +## Overview and terminology + +The emitted __program traces__ (streams of __messages__ of arbitrary data types, where each data type defines a number of different __messages__) are collected across all program components, and undergo __trace interpretation__ by the __dispatcher__ into __metrics__ and __messages__, which are afterwards externalised. + +Therefore, we can conceptually decompose the __tracing system__ into three components: + +* __frontend__, the entry point for __program trace__ collection, which is just a single function `traceWith`; Program locations that invoke this frontend (thereby injecting messages into the tracing system) is called __trace-ins__. +* __dispatcher__, is a structured, namespaced set of contravariantly-composed transformations, triggered by the entry point. Its role is specifically __trace interpretation__; +* __backend__, externalises results of the interpretation ( __metrics__ and __messages__) outside the system, through __trace-outs__. + +The trace-emitting program itself is only exposed to the the frontend part of the tracing system, as it only needs to define the traces themselves, and specify the __trace-ins__ -- call sites that inject traces. It is notably free from any extra obligations, such as the need to define the `LogFormatting` instances. + +As mentioned above, __dispatcher__ is the point of interpretation of the program traces -- a structured set of __Tracer__ objects, that defines and implements the __language and policy__ of __trace interpretation__. + +__Trace interpretation__ is specified in terms of: + +* __trace synthesis__, which means production of __synthetic traces__ -- in cases where we decide it is cheaper (or at all possible) to perform trace aggregation inside the program, +* __trace naming__, which is assignment of hierarchically-structured names to all traces -- which serve identification, documentation and configuration purposes, +* __trace filtering__: which, in turn relies on notions of __severity__, __privacy__ and __frequency__ of messages, +* __trace presentation__ : relying on __detail level__ and on the `LogFormatting` transformation of the traces into JSON, human readable and metric forms -- the last step before traces meet their __trace-outs__, +* __trace documentation__, as a mode of the __dispatcher__ operation. + +The __trace interpretation__ process requires that for each traced type the __dispatcher__ is provided with: + +* instances of the `LogFormatting` typeclass, and +* __trace prototypes__ and __trace documentation__. + +__Trace interpretation__ would have been unusably static, if it wasn't allowed to be configured without recompilation -- and therefore the __effective tracing policy__ used by the __dispatcher__ can be partially defined by the externally-supplied __trace configuration__. + +The __effective tracing policy__ defines for each trace a __trace context__, which is what effectively informs interpretation performed by the __dispatcher__ for that particular trace. + +The __trace context__, in turn, consists of the __logging context__ encoded in the __dispatcher__, and the __configuration context__ coming from the __trace configuration__. + +As a final note, the __dispatcher__ is not provided by the `trace-dispatcher` library as a ready-made, turn-key component -- instead, we are provided with __trace combinators__, the building blocks that allow its construction -- and therefore, expression of the desirable __trace interpretation policies__. + +# Interface overview + +## The trace / tracer duality + +__Traces__ begin with a definition of their values, or __messages__. As an example: + +```haskell +data TraceAddBlockEvent blk = + IgnoreBlockOlderThanK (RealPoint blk) + | IgnoreBlockAlreadyInVolatileDB (RealPoint blk) + ... +``` + +__Traces__ cannot be entered into the tracing system, unless they are accompanied by a matching __tracer__ -- a monadic callback, that expresses the action of tracing of values of that particular type: + +```haskell +trAddBlock :: Trace IO (TraceAddBlockEvent blk) +``` + +From the user perspective, __tracers__ can be approximated (WARNING: simplification!) as: + +```haskell +data Tracer m a = Trace (a -> m ()) +``` + +## Emitting traces + +To actually emit a trace, given a __message__ and a corresponding tracer, the `traceWith` function needs to be used: + +```haskell +traceWith :: Trace m a -> a -> m () +traceWith trAddBlock (IgnoreBlockOlderThanK p) +``` + +## Tracer namespace + +__Tracers__ are organised into a hierarchical __tracer namespace__, where the tree nodes and leaves are identified by `Text` name components. + +The __trace dispatcher__ must be composed in such a way, that all messages have unique name in this namespace. Note, that there is no such requirement placed on the tracers supplied by the client code -- it is, indeed, a property that must be enforced by the dispatcher defined in terms of this library. + +The __tracer namespace__ appears in the following contexts: + +* __documentation__, where it defines the overall structure of the generated documentation output, +* __configuration__, where it allows referring to tracers we want to reconfigure in some way, such as changing their severity, +* __trace-outs__, where the __metrics__ and __messages__ carry the __tracer name__. + +Given a __tracer__ with a particular __tracer name__, we can derive a tracer with an extended __tracer name__: + +```haskell +appendName :: Monad m => Text -> Trace m a -> Trace m a +``` + +As an example, consider the following tracer: + +``` +appendName "specific" $ appendName "middle" $ appendName "general" tracer +``` + +..which will have the name `["general", "middle", "specific"]`. + +## Trace context + +As mentioned in the overview, __traces__ are interpreted by the __dispatcher__ in a __trace context__. This context consists of two parts: + +* the __logging context__ of the trace, as introduced by __trace combinators__, and +* the __configuration context__ coming from the program configuration (initial or runtime). + +Both pieces meet together, to inform the following decisions: + +1. __trace filtering__ -- whether a trace reaches particular __trace-outs__ or not, +2. __trace presentation__ -- which detail level is used during transformation of the __trace__ into __messages__. + +The __logging context__ of the trace is defined as follows: + +1. __trace filtering__ -- by __privacy__, __severity__ and __namespace__ context, +2. __trace presentation__ -- by __detail level__ context. + +Severity an detail level can be configured. + +## Filter context +### Severity + +__Severity__ is expressed in terms of the enumeration provided by [section 6.2.1 of RFC 5424](https://tools.ietf.org/html/rfc5424#section-6.2.1): + +```haskell +data SeverityS + = Debug | Info | Notice | Warning | Error | Critical | Alert | Emergency +``` + +..which ranges from minimum (`Debug`) to the maximum (`Emergency`) severity, and allows ignoring messages with severity level _below_ a configured global __severity cutoff__. + +The following __trace combinators__ affect __annotated severity__ of a trace: + +```haskell +withSeverity :: Monad m => (a -> Severity) -> Trace m a -> Trace m a +setSeverity :: Monad m => Severity -> Trace m a -> Trace m a + +-- Unconditional annotation: +tracer = setSeverity Notice trAddBlock + +-- Conditional annotation: +tracer'' = withSeverity (\case + IgnoreBlockOlderThanK{} -> Warning + IgnoreBlockAlreadyInVolatileDB{} -> Notice) + trAddBlock +``` + +If the combinators are applied multiple times to a single trace, only the outermost application affects it -- the rest of them is ignored. + +```haskell +traceWith (setSeverity Warning trAddBlock) (IgnoreBlockOlderThanK b) +``` + +In addition, the __severity context__ of a particular trace can be further overriden by configuration, at the __tracer namespace__ granularity -- which allows to put them above or below the __global severity cutoff__, effectively either enabling or disabling them. + +`Info` is the default __severity__, in the absence of trace context or configured severity overrides. + +NOTE: as en extension to the filtering severity type (`SeverityF`), a `SilenceF` constructor is defined, which encodes unconditional silencing of a particular trace -- and therefore serves as a semantic expression of the `nullTracer` functionality. + +### Privacy + +__Privacy__ annotations allows limiting __trace-outs__ that particular traces can reach. It is expressed in terms of: + +```haskell +data Privacy + = Confidential | Public +``` + +__Confidential__ privacy level means that the trace will not be externalised from the system, except via __standard output__. + +The annotation mechanism is similar to the one of severity: + +```haskell +privately :: Trace m a -> Trace m a +withPrivacy :: Monad m => (a -> Privacy) -> Trace m a -> Trace m a +``` + +`Public` is the default __privacy__, in the absence of privacy annotations. + +Trace privacy cannot be configured. + +See [Confidentiality and privacy filtering implementation](#Confidentiality-and-privacy -filtering-implementation) for a more full discussion of semantics. + +To further prevent occasional leaks of `Confidential` traces, all output from those traces is tagged with the `CONFIDENTIAL` keyword. + +### Frequency + +__Frequency filtering__ is yet another part of __trace filtering__, and represents an optional limit on the observable frequency of individual trace messages. + +Semantically, this is corresponds to a randomly-fair suppression of messages within a particular trace, when their moving-average frequency exceeds a given threshold parameter. + +The __frequency limiter__ itself emits a __suppression summary__ message under the following conditions: + +* when it message suppression begins, and +* when message suppression stops -- adding the number of suppressed messages. + +__Frequency limiters__ are given a name to identify its activity. + +```haskell +limitFrequency + :: MonadIO m + => Double -- ^ messages per second + -> Text -- ^ name of this limiter + -> Trace m a -- ^ the limited trace + -> Trace m LimitingMessage -- ^ a trace emitting the messages of the limiter + -> m (Trace m a) -- ^ the original trace + +data LimitingMessage = + StartLimiting Text + | StopLimiting Text Int +``` + +The frequency filtering is intended to be applied to a subset of traces (those known to be noisy). For this subset of traces the frequency limit can be configured. + +## Presentation +### Formatting + +The `LogFormatting` typeclass is used to describe __trace presentation__ -- mapping __traces__ to __metrics__ and __messages__. + +* The `forMachine` method is used for a machine readable representation, which can varied through detail level. + It requires an implementation to be provided by the trace author. + +* the `forHuman` method shall represent the message in human readable form. + It's default implementation defers to `forMachine`. + +* the `asMetrics` method shall represent the message as `0` to `n` metrics. + It's default implementation assumes no metrics. If a text is given it is + appended as last element to the namespace. + +```haskell +class LogFormatting a where + forMachine :: DetailLevel -> a -> A.Object + + forHuman :: a -> Text + forHuman = forMachine DNormal + + asMetrics :: a -> [Metric] + asMetrics v = [] + +data Metric + = IntM (Maybe Text) Int + | DoubleM (Maybe Text) Double + deriving (Show, Eq) +``` + +The standard formatters transform a stream of messages of `a`, where `a` is an instance of `LogFormatter` to a stream of `FormattedMessages`. + +```haskell +data FormattedMessage + = Human Text + | Machine Text + | Metrics [Metric] +``` + +`humanFormatter` takes a `Bool` argument, which tells if color codes for the standard output __trace-out__ shall be inserted, and an argument which is the app name, which gets prepended to the namespace, while the `machineFormatter` has as arguments the desired detail level and as well the application name. `metricsFormatter` takes no extra arguments: + +```haskell +humanFormatter :: (LogFormatting a, MonadIO m) + => Bool + -> Text + -> Trace m FormattedMessage + -> m (Trace m a) + +machineFormatter :: (LogFormatting a, MonadIO m) + => DetailLevel + -> Text + -> Trace m FormattedMessage + -> m (Trace m a) + +metricsFormatter :: (LogFormatting a, MonadIO m) + => Trace m FormattedMessage + -> m (Trace m a) +``` + +The __detail level__ can be configured globally, and also per-trace, by referring to a particular __tracer name__. + +#### Decide on more direct interface to EKG metrics + +> One problem with the `asMetrics` interface, is that it forces an intermediate representation on the metrics flow -- an it also doesn't express all possibilities that EKG store provides. + +### Detail level + +An aspect of __trace presentation__ is the amount of details presented for each trace. This is important, because the emitted __program traces__ might contain extreme details, which, if presented in full, would have made handling of the trace extremely expensive. This detail control mechanism is configurable up to specific messages. + +This detail level control is expressed by: + +```haskell +data DetailLevel = DMinimal | DNormal | DDetailed | DMaximum +``` + +## Fold-based aggregation + +If aggregated information from multiple consecutive messages is needed the following fold functions can be used: + + +```haskell +-- | Folds the function with state b over messages a in the trace. +foldTraceM :: MonadIO m + => (acc -> a -> acc) + -> acc + -> Trace m (Folding a acc) + -> m (Trace m a) + +foldMTraceM :: forall a acc m . MonadIO m + => (acc -> a -> m acc) + -> acc + -> Trace m (Folding a acc) + -> m (Trace m a) + +newtype Folding a acc = Folding acc +``` + +Since __tracers__ can be invoked from different threads, an `MVar` is used internally to secure correct behaviour. + +As an example we want to log a measurement value together with the sum of all measurements that occurred so far. For this we define a `Measure` type to hold a `Double`, a `Stats` type to hold the the sum together with the measurement and a `fold`-friendly function to calculate new `Stats` from old `Stats` and `Measure`: + +```haskell +data Stats = Stats { + sMeasure :: Double, + sSum :: Double + } + +calculateS :: Stats -> Double -> Stats +calculateS Stats{..} val = Stats val (sSum + val) +``` + +Then we can define the aggregation tracer with the procedure foldTraceM in the +following way, and it will output the Stats: + +```haskell + aggroTracer <- foldTraceM calculateS (Stats 0.0 0.0) exTracer + traceWith 1.1 aggroTracer -- measure: 1.1 sum: 1.1 + traceWith 2.0 aggroTracer -- measure: 2.0 sum: 3.1 +``` + +### Discuss possibility of pure aggregation + +> I would like to find a function `foldTrace`, that omits the MVar and can thus be called pure. Help is appreciated. + +## Dispatcher routing toolkit + +During definition of the __trace dispatcher__, it is sometimes useful to have a number of functions to route them. + +To send the message of a trace to different tracers depending on some criteria use the following function: + +```haskell +routingTrace :: Monad m => (a -> Trace m a) -> Trace m a +let resTrace = routingTrace routingf (tracer1 <> tracer2) + where + routingf LO1 {} = tracer1 + routingf LO2 {} = tracer2 +``` + +The second argument must mappend all possible tracers of the first argument to one tracer. This is required for the configuration. We could have construct a more secure interface by having a map of values to tracers, but the ability for full pattern matching outweigh this disadvantage in our view. +In the following example we send the messages of one trace to two tracers simultaneously: + +```haskell +let resTrace = tracer1 <> tracer2 +``` + +To route one trace to multiple tracers simultaneously we use the fact that Tracer is a `Semigroup` and then use `<>`, or `mconcat` for lists of tracers: + +```haskell +(<>) :: Monoid m => m -> m -> m +mconcat :: Monoid m => [m] -> m +``` + +In the third example we unite two traces to one tracer, for which we trivially use the same tracer on the right side. + +```haskell +tracer1 = appendName "tracer1" exTracer +tracer2 = appendName "tracer2" exTracer +``` + +## Configuration + +The configurability of __dispatchers__ this library allows to define is based on: + +1. __Tracer namespace__-based configurability, down to single __message__ granularity, +2. Runtime reconfigurability, triggered by invocation of `configureTracers`, +3. Prototypes for each __message__. + +Reconfiguration can be triggered at runtime and essentially involves running the entire __dispatcher__ trace network, by doing trace specialisation for each trace that has __prototypes__ defined. + +```haskell +-- The function configures the traces with the given configuration +configureTracers :: Monad m => TraceConfig -> Documented a -> [Trace m a]-> m () +``` + +These are the options that can be configured based on a namespace: + +```haskell +data ConfigOption = + -- | Severity level for filtering (default is WarningF) + CoSeverity SeverityF + -- | Detail level of message representation (Default is DNormal) + | CoDetail DetailLevel + -- | To which backend to pass + -- Default is [EKGBackend, Forwarder, Stdout HumanFormatColoured] + | CoBackend [BackendConfig] + -- | Construct a limiter with name (Text) and limiting to the Double, + -- which represents frequency in number of messages per second + | CoLimiter Text Double + +data BackendConfig = + Forwarder + | Stdout FormatLogging + | EKGBackend + +data TraceConfig = TraceConfig { + -- | Options specific to a certain namespace + tcOptions :: Map.Map Namespace [ConfigOption] + -- | Options for trace-forwarder + , tcForwarder :: RemoteAddr + , tcForwarderQueueSize :: Int +} +``` + +If the configuration file is in Yaml format, the following entry means, that by default +all messages with Info or higher Priority or higher are shown: + +```yaml +TraceOptionSeverity: + - ns: '' + severity: InfoF +``` + +But if you want to see Debug messages of the ChainDB tracer, then add: + +```yaml +TraceOptionSeverity: + - ns: '' + severity: InfoF + - ns: Node.ChainDB + severity: DebugF +``` + +And if you never want to see any message of the AcceptPolicy tracer, then add: + +```yaml +TraceOptionSeverity: + - ns: '' + severity: InfoF + - ns: Node.ChainDB + severity: DebugF + - ns: Node.AcceptPolicy + severity: SilentF +``` + +As another example, if you don't want to see more then 1 BlockFetchClient +message per second, then add this to your configuration file: + +```yaml +TraceOptionLimiter: + - ns: Node.BlockFetchClient + limiterName: BlockFetchLimiter + limiterFrequency: 1.0 +``` + +## Documentation + +The self-documentation features of `trace-dispatcher` are provided by a combination of: + +* __documentation annotations__, expressed by the `Documented a` type, that carry a list of per- __message__ description (of `DocMsg` type), and +* a special __dispatcher__ execution mode that emits documentation for all annotated traces, using the __tracer namespace__ to guide the document structure. + +The per- __message__ `DocMsg` objects combine: + +* __trace prototypes__ -- a stubbed __message__ invocation, +* message documentation text, in Markdown format, + +*Because it is not enforced by the type system, it is very important that each trace provides a complete list of `DocMsg` entries for all message contructors, as these prototypes are also used for configuration*. + +```haskell +newtype Documented a = Documented {undoc :: [DocMsg a]} + +data DocMsg a = DocMsg { + dmPrototype :: a + , dmMetricsMD :: [(Text, Text)] + , dmMarkdown :: Text +} +``` + +### Discuss impact of missing documentation entries + +What is the worst case impact of a missing `DocMsg`? + +How can we reduce that impact? + +# Integration and implementation in the node +## Overall tracing setup + +As a result of the __trace__ / __tracer__ duality, the program components that wish to emit traces of particular types, must be parametrised with matching tracers. + +Because all these tracers are defined as part of the __dispatcher__ definition, which is itself defined in a centralised location, that allows a certain program structure to emerge: + +1. The program initialisation routine reads __trace configuration__ and uses that to parametrise the __dispatcher__ that is meant to express a __tracing policy__ defined by that configuration. + +2. As mentioned previously, that dispatcher is generally expressed as a structured value, that defines per-program-component set of __tracers__. + +3. This __dispatcher__ (in other words, the set of __tracers__ it is composed of) is given as an argument to the rest of the program, which then distributes them across its components and then begins execution. + +## Trace-outs + +__Trace-outs__, as mentioned before, are final destinations of all __traces__, after they have undergone __trace interpretation__ into __metrics__ and __messages__. + +There are exactly two __trace-outs__ defined for the system: + +1. `stdout`, the basic standard output destination. It is notable in that it can also accept `Confidential` traces. +2. `trace-forward`, a purely network-only sink that forwards __messages__ using a combination of dedicated protocols over TCP or local sockets. Only capable of forwarding `Public` traces. + +`forwardingTracer` is intended to be used as a __message__ source for `RTView` and `cardano-logger`. + +`ekgTracer` submits metrics to a local EKG store, which can then export messages further. + +```haskell +stdoutTracer :: MonadIO m + => Maybe FilePath + -> m (Trace m FormattedMessage) + +forwardingTracer :: MonadIO m + => ForwardTarget + -> m (Trace m FormattedMessage) + +ekgTracer :: MonadIO m + => Ekg.Store + -> m (Trace m FormattedMessage) +``` + +Configuring a __trace-out__ to output human-readable text (and therefore to use the human formatter), produces a presentation of the form `[HOST:NAMESPACE] (SEVERITY.THREADID)`: + + [deus-x-machina:cardano.general.middle.specific](Info.379) + +### Decide trace-outs types + +> We shouldn't implement file-based tracing, unless we intend to implement it properly, i.e. with log rotation. +> +> One reason why writing to a file in the stdout backend is somewhat undesirable, is because it weakens the security property we assign to this backend -- the Confidential-ity enforcement. +> +> We should consider that we already have a dedicated `cardano-logger` component for file logging. + +### Explicit trace filtering + +__Trace filtering__ is affected by __annotation__ and __configuration__ components of the trace's __severity context__ as follows: + +1. The effective __configuration severity__ of a trace is determined as a the __most specific__ configuration-specified __severity__. +2. The trace is then ignored, if the trace's __annotated severity__ is __less__ than its __configuration severity__. + +For the purposes of trace dispatcher implementation, direct trace filtering can be done by `filterTraceBySeverity`, which only processes messages further with a severity equal or greater as the given one. E.g.: + +```haskell +let filteredTracer = filterTraceBySeverity WarningF exampleTracer +``` + +A more general filter function is offered, which gives access to the object and a `LoggingContext`, which contains the namespace, the severity, the privacy and the detailLevel: + +```haskell +--- | Don't process further if the result of the selector function +--- is False. +filterTrace :: (Monad m) => + ((LoggingContext, a) -> Bool) + -> Trace m a + -> Trace m a + +data LoggingContext = LoggingContext { + lcNamespace :: Namespace + , lcSeverity :: Maybe Severity + , lcPrivacy :: Maybe Privacy + , lcDetailLevel :: Maybe DetailLevel +} +``` +So you can e.g. write a filter function, which only displays _Public_ messages: + +```haskell +filterTrace (\ (c, a) -> case lcPrivacy c of + Just s -> s == Public + Nothing -> True) +``` + +## Confidentiality and privacy filtering implementation + +__Trace filtering__ is affected by the __privacy context__ as follows: + +1. `Confidential` traces can only reach the `stdout` __trace-out__. +2. `Public` traces reach both the `stdout` and `trace-forwarder` __trace-outs__. + +In effect, it is impossible to leak the `Confidential` traces due to logging misconfiguration -- a leak can only happen if the user explicitly allows network access to the standard output of the traced program. + +## Documentation generation + +To generate the documentation, first call `documentMarkdown` with the `Documented` type and all the tracers that are called. Do this for all message types you need, and then call `buildersToText` with the appended lists. + +```haskell + b1 <- documentMarkdown traceForgeEventDocu [t1, t2] + b2 <- documentMarkdown .. .. + .. + bn <- documentMarkdown .. .. + writeFile "Docu.md" (buildersToText (b1 ++ b2 ++ ... ++ bn)) +``` + +The generated documentation for a simple message my look like this: + +> #### cardano.node.StartLeadershipCheck +> For human: +> `Checking for leadership in slot 1` +> +> For machine: +> `{"kind":"TraceStartLeadershipCheck","slot":1}` +> +> Integer metrics: +> `aboutToLeadSlotLast 1` +> +> > Severity: `Info` +> > +> > Privacy: `Public` +> > +> > Details: `DNormal` +> +> Backends: `KatipBackend ""` / `Machine`, `KatipBackend ""` / `Human` +> +> *** +> Start of the leadership check +> +> We record the current slot number. +> *** + +# Appendix + +## Decisions + +### Decide inline trace type annotation with trace function + +__DECISION: move `traceNamed` to the dispatcher API__ + +> Alternatively, to trace that value, while extending the name of the trace inside the program (as opposed to deferring that to the dispatcher), the __trace__ function can be used: +> +> ```haskell +> traceNamed trAddBlock "ignoreBlock" (IgnoreBlockOlderThanK p) +> ``` + +### Decide tracer definedness + +DECISION: Every __message__ has to have a unique tracer name. + +DECISION: Therefore, each __tracer__ has a __namespace__ assigned to it, which is, conceptually, a potentially empty list of `Text` identifiers. + +### Decide tracer name definition + +> We could have used the (`Type` * `Constructor`) pair, which is a more technical approach. Problems with that: +> 1. __synthetic traces__ exist. +> 2. Developer-provided type/constructor names are not necessarily ideal from user standpoint. + +DECISION: there is value in maintaining a user-friendly trace message namespace. + +### Decide inline trace type annotation with trace function 2 + +DECISION: we use `traceWith` in the library code and `traceNamed` in th dispatcher. + +> Since we require that every message has its unique name we encourage the use of the already introduced convenience function: +> +> ```haskell +> traceNamed exampleTracer "ignoreBlock" (IgnoreBlockOlderThanK b) +> -- instead of: +> traceWith (appendName "ignoreBlock" exampleTracer) (IgnoreBlockOlderThanK b) +> ``` + +### Decide on explicit trace filtering + +DECISION: move to [Integration and implementation in the node](#Integration-and-implementation-in-the-node). + +### Decide on privately combinator + +> Instead of the `setPrivacy` combinator, we could save the trouble of passing the privacy argument, by relying on the fact that default privacy is `Public`, and introduce instead a `privately` combinator: +> +> ```haskell +> privately :: Trace m a -> Trace m a +> ``` +> This combinator potentially entirely replaces `setPrivacy` and `withPrivacy`. + +DECISION: we agree to add `privately` to the API. + +### Decide on dispatcher detail level control + +It doesn't seem to make sense to decide on detail level inside the dispatcher -- so seems to be a purely configuration+`LogFormatting`-defined mechanism. + +DECISION: Move to the implementation API. + +### Decide namespace-aware configuration + +> It doesn't make a lot of sense to configure Privacy. +> +> It could make sense to configure frequency limits. + +DECISION: Move to the implementation API. Privacy should not be configurable. Frequency limits should be configurable, at least globally -- maybe not per-namespace. + +### Decide missing configuration + +DECISION: + +* Global severity cutoff + per namespace. +* Global detail level + per namespace. +* Global *trace-out* configuration: stdout, trace forwarder. + +#### Decide on type errors instead of silent dropping of messages + +> We cannot allow silent dropping of messages, which is relevant in light of the above: +> +> > It's default implementation assumes no machine representation. + +DECISION: forMachine is a required method. + +#### Decide extra privacy tagging + +DECISION: to further prevent occasional leaks of `Confidential` traces, all output from those traces is tagged with the `CONFIDENTIAL` keyword. + +## Future work + +There is a number of topics that were discussed, but deferred to a latter iteration of design/implementation: + +1. Lightweight documentation references, GHC style -- this would allow us to refer to named pieces of documentation in source code, as opposed to copy-pasting them into trace documentation. +2. Change of human-oriented presentation machinery. diff --git a/trace-dispatcher/examples/Examples/Aggregation.hs b/trace-dispatcher/examples/Examples/Aggregation.hs new file mode 100644 index 00000000000..3754532deed --- /dev/null +++ b/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 diff --git a/trace-dispatcher/examples/Examples/Configuration.hs b/trace-dispatcher/examples/Examples/Configuration.hs new file mode 100644 index 00000000000..b5ff98f48d9 --- /dev/null +++ b/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 diff --git a/trace-dispatcher/examples/Examples/Documentation.hs b/trace-dispatcher/examples/Examples/Documentation.hs new file mode 100644 index 00000000000..261066f5d00 --- /dev/null +++ b/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 diff --git a/trace-dispatcher/examples/Examples/EKG.hs b/trace-dispatcher/examples/Examples/EKG.hs new file mode 100644 index 00000000000..9d7671b75e5 --- /dev/null +++ b/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) diff --git a/trace-dispatcher/examples/Examples/FrequencyLimiting.hs b/trace-dispatcher/examples/Examples/FrequencyLimiting.hs new file mode 100644 index 00000000000..32d7f3b2091 --- /dev/null +++ b/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 diff --git a/trace-dispatcher/examples/Examples/Routing.hs b/trace-dispatcher/examples/Examples/Routing.hs new file mode 100644 index 00000000000..93523d4f372 --- /dev/null +++ b/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 diff --git a/trace-dispatcher/examples/Examples/TestObjects.hs b/trace-dispatcher/examples/Examples/TestObjects.hs new file mode 100644 index 00000000000..159f992eb4c --- /dev/null +++ b/trace-dispatcher/examples/Examples/TestObjects.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Examples.TestObjects ( + traceForgeEventDocu + , TraceForgeEvent(..) + , LogBlock(..) + , SlotNo(..) + , withSeverityTraceForgeEvent + , message1 + , message2 + , message3 + , message4 +) where + +import Cardano.Logging +import qualified Data.Aeson as AE +import qualified Data.HashMap.Strict as HM +import Data.Kind (Type) +import Data.Text (Text, pack) +import Data.Word (Word64) +import GHC.Generics +import Text.Printf (printf) + +newtype SlotNo = SlotNo {unSlotNo :: Word64} + deriving (Eq, Ord, Show, Generic) + +instance AE.ToJSON SlotNo where + toEncoding = AE.genericToEncoding AE.defaultOptions + +newtype Point block = Point + { getPoint :: WithOrigin (Block SlotNo (HeaderHash block)) + } + deriving (Generic) + + +instance AE.ToJSON (Point LogBlock) where + toEncoding = AE.genericToEncoding AE.defaultOptions + +class ( Eq (HeaderHash b) + , Ord (HeaderHash b) + , Show (HeaderHash b) + ) => StandardHash b + +deriving newtype instance StandardHash block => Eq (Point block) +deriving newtype instance StandardHash block => Ord (Point block) +deriving newtype instance StandardHash block => Show (Point block) + +data Block slot hash = Block + { blockPointSlot :: !slot + , blockPointHash :: !hash + } + deriving (Eq, Ord, Show, Generic) + +instance (AE.ToJSON h, AE.ToJSON s) => AE.ToJSON (Block s h) where + toEncoding = AE.genericToEncoding AE.defaultOptions + +data WithOrigin t = Origin | At !t + deriving + ( Eq, + Ord, + Show, + Generic + ) + +instance AE.ToJSON a => AE.ToJSON (WithOrigin a) where + toEncoding = AE.genericToEncoding AE.defaultOptions + +newtype BlockNo = BlockNo {unBlockNo :: Word64} + deriving stock (Eq, Ord, Generic, Show) + deriving newtype (Enum, Bounded, Num) + +instance AE.ToJSON BlockNo where + toEncoding = AE.genericToEncoding AE.defaultOptions + +data LogBlock = LogBlock + deriving(Eq, Ord, Show, StandardHash) + +type family HeaderHash b :: Type + +type instance HeaderHash LogBlock = LogHash + +newtype LogHash = LogHash { unLogHash :: Word64 } + deriving (Eq, Ord, Show, Generic) + +instance AE.ToJSON LogHash where + toEncoding = AE.genericToEncoding AE.defaultOptions + +showT :: Show a => a -> Text +showT = pack . show + +-- The actual test trace messages +data TraceForgeEvent blk + = TraceStartLeadershipCheck SlotNo + | TraceSlotIsImmutable SlotNo (Point blk) BlockNo + | TraceBlockFromFuture SlotNo SlotNo + deriving (Eq, Show, Generic) + +instance LogFormatting (TraceForgeEvent LogBlock) where + forHuman (TraceStartLeadershipCheck slotNo) = pack $ + printf + "Checking for leadership in slot %u" + (unSlotNo slotNo) + forHuman (TraceSlotIsImmutable slotNo immutableTipPoint immutableTipBlkNo) = pack $ + printf + "Couldn't forge block because slot %u is immutable. \ + \ Immutable tip: %s, immutable tip block no: %i." + (unSlotNo slotNo) + (show immutableTipPoint) + (unBlockNo immutableTipBlkNo) + forHuman (TraceBlockFromFuture currentSlot tipSlot) = pack $ + printf + "Couldn't forge block because tip %u of slot %u is in the future." + (unSlotNo tipSlot) + (unSlotNo currentSlot) + + forMachine _verb (TraceStartLeadershipCheck slotNo) = + HM.fromList + [ "kind" AE..= AE.String "TraceStartLeadershipCheck" + , "slot" AE..= AE.toJSON (unSlotNo slotNo) + ] + forMachine _verb (TraceSlotIsImmutable slotNo tipPoint tipBlkNo) = + HM.fromList + [ "kind" AE..= AE.String "TraceSlotIsImmutable" + , "slot" AE..= AE.toJSON (unSlotNo slotNo) + , "tip" AE..= showT tipPoint + , "tipBlockNo" AE..= AE.toJSON (unBlockNo tipBlkNo) + ] + forMachine _verb (TraceBlockFromFuture currentSlot tip) = + HM.fromList + [ "kind" AE..= AE.String "TraceBlockFromFuture" + , "current slot" AE..= AE.toJSON (unSlotNo currentSlot) + , "tip" AE..= AE.toJSON (unSlotNo tip) + ] + + asMetrics (TraceStartLeadershipCheck slotNo) = + [IntM ["aboutToLeadSlotLast"] (fromIntegral $ unSlotNo slotNo)] + asMetrics (TraceSlotIsImmutable slot _tipPoint _tipBlkNo) = + [IntM ["slotIsImmutable"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceBlockFromFuture slot _slotNo) = + [IntM ["blockFromFuture"] (fromIntegral $ unSlotNo slot)] + +traceForgeEventDocu :: Documented (TraceForgeEvent LogBlock) +traceForgeEventDocu = Documented + [ DocMsg + (TraceStartLeadershipCheck (SlotNo 1)) + [] + "Start of the leadership check\n\ + \\n\ + \We record the current slot number." + , DocMsg + (TraceSlotIsImmutable (SlotNo 1) (Point Origin) (BlockNo 1)) + [] + "Leadership check failed: the tip of the ImmutableDB inhabits the\n\ + \current slot\n\ + \\n\ + \This might happen in two cases.\n\ + \\n\ + \1. the clock moved backwards, on restart we ignored everything from the\n\ + \ VolatileDB since it's all in the future, and now the tip of the\n\ + \ ImmutableDB points to a block produced in the same slot we're trying\n\ + \ to produce a block in\n\ + \\n\ + \2. k = 0 and we already adopted a block from another leader of the same\n\ + \ slot.\n\ + \\n\ + \We record both the current slot number as well as the tip of the\n\ + \ImmutableDB.\n\ + \\n\ + \See also " + , DocMsg + (TraceBlockFromFuture (SlotNo 1) (SlotNo 1)) + [] + "Leadership check failed: the current chain contains a block from a slot\n\ + \/after/ the current slot\n\ + \\n\ + \This can only happen if the system is under heavy load.\n\ + \\n\ + \We record both the current slot number as well as the slot number of the\n\ + \block at the tip of the chain.\n\ + \\n\ + \See also " + ] + +withSeverityTraceForgeEvent :: Monad m => + Trace m (TraceForgeEvent blk) + -> Trace m (TraceForgeEvent blk) +withSeverityTraceForgeEvent = withSeverity (\case + TraceStartLeadershipCheck {} -> Info + TraceSlotIsImmutable {} -> Error + TraceBlockFromFuture {} -> Error + ) + +message1 :: TraceForgeEvent LogBlock +message1 = TraceStartLeadershipCheck (SlotNo 1001) + +message2 :: TraceForgeEvent LogBlock +message2 = TraceSlotIsImmutable (SlotNo 3333) (Point Origin) (BlockNo 1) + +message3 :: TraceForgeEvent LogBlock +message3 = TraceBlockFromFuture (SlotNo 4400) (SlotNo 300) + +message4 :: TraceForgeEvent LogBlock +message4 = TraceStartLeadershipCheck (SlotNo 2002) diff --git a/trace-dispatcher/examples/Examples/Trivial.hs b/trace-dispatcher/examples/Examples/Trivial.hs new file mode 100644 index 00000000000..f91d8762997 --- /dev/null +++ b/trace-dispatcher/examples/Examples/Trivial.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Examples.Trivial ( + test1 + , test2 +) where + + +import Cardano.Logging +import Examples.TestObjects + + +-- | Make shure the function append name is only called once +-- for every path element +test1 :: IO () +test1 = do + stdoutTracer' <- standardTracer Nothing + simpleTracer <- machineFormatter "cardano" stdoutTracer' + configureTracers emptyTraceConfig traceForgeEventDocu [simpleTracer] + let simpleTracer1 = filterTraceBySeverity (Just WarningF) simpleTracer + let simpleTracerC1 = appendName "Outer1" simpleTracer1 + let simpleTracerC2 = appendName "Inner1" simpleTracerC1 + let simpleTracerC3 = setSeverity Error + $ setPrivacy Confidential + $ appendName "Inner2" simpleTracerC1 + traceWith (setSeverity Error simpleTracerC2) message1 + traceWith (setSeverity Warning simpleTracerC3) message2 + traceWith simpleTracerC2 message3 + traceWith (setSeverity Critical (appendName "Inner3" simpleTracerC3)) message4 + +test2 :: IO () +test2 = do + stdoutTracer' <- standardTracer Nothing + simpleTracer <- humanFormatter True "cardano" stdoutTracer' + configureTracers emptyTraceConfig traceForgeEventDocu [simpleTracer] + let simpleTracer1 = withSeverity loSeverity + (filterTraceBySeverity (Just WarningF) simpleTracer) + let simpleTracerC1 = appendName "Outer1" simpleTracer1 + let simpleTracerC2 = appendName "Inner1" simpleTracerC1 + let simpleTracerC3 = setPrivacy Confidential $ appendName "Inner2" simpleTracerC1 + traceWith simpleTracerC2 message1 + traceWith (setSeverity Critical simpleTracerC3) message2 + traceWith simpleTracerC2 message3 + traceWith (appendName "Inner3" simpleTracerC3) message4 + traceWith (appendName "cont1" $ appendName "cont2" $ appendName "cont3" simpleTracerC2) message1 + +loSeverity :: TraceForgeEvent LogBlock -> SeverityS +loSeverity TraceStartLeadershipCheck {} = Warning +loSeverity TraceSlotIsImmutable {} = Error +loSeverity TraceBlockFromFuture {} = Error diff --git a/trace-dispatcher/examples/Main.hs b/trace-dispatcher/examples/Main.hs new file mode 100644 index 00000000000..48705ab53b1 --- /dev/null +++ b/trace-dispatcher/examples/Main.hs @@ -0,0 +1,22 @@ +module Main ( + main +) where + +import Examples.Aggregation +import Examples.Configuration +import Examples.Documentation +import Examples.EKG +import Examples.FrequencyLimiting +import Examples.Routing +import Examples.Trivial + +main :: IO () +main = do + test1 + test2 + testAggregation + testRouting + testConfig + testLimiting + docTracers + testEKG diff --git a/trace-dispatcher/examples/config.json b/trace-dispatcher/examples/config.json new file mode 100644 index 00000000000..efb7e3985d2 --- /dev/null +++ b/trace-dispatcher/examples/config.json @@ -0,0 +1,49 @@ +{ + "TraceOptionSeverity": [ + { + "ns": "", + "severity": "InfoF" + }, + { + "ns": "Cardano.Node.AcceptPolicy", + "severity": "SilenceF" + }, + { + "ns": "Cardano.Node.ChainDB", + "severity": "DebugF" + } + ], + "TraceOptionDetail": [ + { + "ns": "", + "detail": "DNormal" + }, + { + "ns": "Cardano.Node.BlockFetchClient", + "detail": "DMinimal" + } + ], + "TraceOptionBackend": [ + { + "ns": "", + "backends": [ + "Stdout HumanFormatColoured", + "Forwarder", + "EKGBackend" + ] + }, + { + "ns": "Cardano.Node.ChainDB", + "backends": [ + "Forwarder" + ] + } + ], + "TraceOptionForwarder": { + "filePath": "/tmp/forwarder.sock" + }, + "TraceOptionForwardQueueSize": 1000, + "TraceOptionLimiter": [ + + ] +} diff --git a/trace-dispatcher/examples/config.nix b/trace-dispatcher/examples/config.nix new file mode 100644 index 00000000000..6e5d2f3b3e9 --- /dev/null +++ b/trace-dispatcher/examples/config.nix @@ -0,0 +1,18 @@ +To add in node-services.nix + + TraceOptionSeverity = [ + {ns = ""; severity = "InfoF";} + {ns = "Cardano.Node.AcceptPolicy"; severity = "SilenceF";} + {ns = "Cardano.Node.ChainDB"; severity = "DebugF";} + ]; + + TraceOptionDetail = [ + {ns = ""; detail = "DNormal";} + {ns = "Cardano.Node.BlockFetchClient"; detail = "DMinimal";} + ]; + + TraceOptionBackend = [ + {ns = ""; backends = ["Stdout HumanFormatColoured"; "Forwarder"; "EKGBackend"];} + {ns = "Cardano.Node.ChainDB"; backends = ["Forwarder"];} + ]; + TraceOptionForwarder = {filePath: "/tmp/forwarder.sock";}; diff --git a/trace-dispatcher/src/Cardano/Logging.hs b/trace-dispatcher/src/Cardano/Logging.hs new file mode 100644 index 00000000000..d6e0e5aca2f --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging.hs @@ -0,0 +1,15 @@ +module Cardano.Logging ( + module X + ) where + +import Cardano.Logging.Configuration as X +import Cardano.Logging.DocuGenerator as X +import Cardano.Logging.Formatter 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.Standard as X +import Cardano.Logging.Tracer.Forward as X +import Cardano.Logging.Types as X +import Cardano.Logging.Tracer.Composed as X +import Control.Tracer as X hiding (traceWith, nullTracer, Tracer) diff --git a/trace-dispatcher/src/Cardano/Logging/Configuration.hs b/trace-dispatcher/src/Cardano/Logging/Configuration.hs new file mode 100644 index 00000000000..1699a6b03d5 --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/Configuration.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +module Cardano.Logging.Configuration + ( configureTracers + , withNamespaceConfig + , filterSeverityFromConfig + , withDetailsFromConfig + , withBackendsFromConfig + , withLimitersFromConfig + , readConfiguration + , defaultConfig + + , getSeverity + , getDetails + , getBackends + ) where + +import Control.Exception (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import qualified Control.Tracer as T +import qualified Data.Aeson as AE +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (foldl', maximumBy, nub) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text, split, unpack) +import Data.Yaml +import GHC.Generics + +import Cardano.Logging.DocuGenerator (addFiltered, addLimiter) +import Cardano.Logging.FrequencyLimiter (LimitingMessage (..), + limitFrequency) +import Cardano.Logging.Trace (filterTraceBySeverity, setDetails) +import Cardano.Logging.Types + +defaultConfig :: TraceConfig +defaultConfig = emptyTraceConfig { + tcOptions = Map.fromList + [([] :: Namespace, + [ CoSeverity InfoF + , CoDetail DNormal + , CoBackend [Stdout HumanFormatColoured] + ]) + ] + } + +-- | Call this function at initialisation, and later for reconfiguration +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 control (Trace tr) = + T.traceWith tr (emptyLoggingContext, Just control, dmPrototype (head documented)) + configureAllTrace control (Trace tr) = + mapM + ((\ m -> T.traceWith tr (emptyLoggingContext, Just control, m)) . dmPrototype) + documented + +-- | Take a selector function called 'extract'. +-- Take a function from trace to trace with this config dependent value. +-- In this way construct a trace transformer with a config value +withNamespaceConfig :: forall m a b c. (MonadIO m, Ord b) => + String + -> (TraceConfig -> Namespace -> m b) + -> (Maybe b -> Trace m c -> m (Trace m a)) + -> Trace m c + -> m (Trace m a) +withNamespaceConfig name extract withConfig tr = do + ref <- liftIO (newIORef (Left (Map.empty, Nothing))) + pure $ Trace $ T.arrow $ T.emit $ mkTrace ref + where + mkTrace :: + IORef (Either (Map.Map Namespace b, Maybe b) b) + -> (LoggingContext, Maybe TraceControl, a) + -> m () + mkTrace ref (lc, Nothing, a) = do + eitherConf <- liftIO $ readIORef ref + case eitherConf of + Right val -> do + tt <- withConfig (Just val) tr + T.traceWith + (unpackTrace tt) (lc, Nothing, a) + Left (cmap, Just v) -> + case Map.lookup (lcNamespace lc) cmap of + Just val -> do + tt <- withConfig (Just val) tr + T.traceWith (unpackTrace tt) (lc, Nothing, a) + Nothing -> do + tt <- withConfig (Just v) tr + T.traceWith (unpackTrace tt) (lc, Nothing, a) + Left (_cmap, Nothing) -> error ("Missing configuration " <> name <> " ns " <> show (lcNamespace lc)) + mkTrace ref (lc, Just Reset, a) = do +-- trace ("mkTrace Reset " <> show (lcNamespace lc)) $ pure () + liftIO $ writeIORef ref (Left (Map.empty, Nothing)) + tt <- withConfig Nothing tr + T.traceWith (unpackTrace tt) (lc, Just Reset, a) + + mkTrace ref (lc, Just (Config c), m) = do +-- trace ("mkTrace Config " <> show (lcNamespace lc)) $ pure () + ! val <- extract c (lcNamespace lc) + eitherConf <- liftIO $ readIORef ref + case eitherConf of + Left (cmap, Nothing) -> + case Map.lookup (lcNamespace lc) cmap of + Nothing -> do + liftIO + $ writeIORef ref + $ Left (Map.insert (lcNamespace lc) val cmap, Nothing) + Trace tt <- withConfig (Just val) tr + T.traceWith tt (lc, Just (Config c), m) + Just v -> do + if v == val + then do + Trace tt <- withConfig (Just val) tr + T.traceWith tt (lc, Just (Config c), m) + else error $ "Inconsistent trace configuration with context " + ++ show (lcNamespace lc) + Right _val -> error $ "Trace not reset before reconfiguration (1)" + ++ show (lcNamespace lc) + Left (_cmap, Just _v) -> error $ "Trace not reset before reconfiguration (2)" + ++ show (lcNamespace lc) + + mkTrace ref (lc, Just Optimize, m) = do + eitherConf <- liftIO $ readIORef ref + case eitherConf of + Left (cmap, Nothing) -> + case nub (Map.elems cmap) of + [] -> -- trace ("mkTrace Optimize empty " <> show (lcNamespace lc)) $ + -- This will never be called!? + pure () + [val] -> do + -- trace ("mkTrace Optimize one " <> show (lcNamespace lc) + -- <> " val " <> show val) $ pure () + liftIO $ writeIORef ref $ Right val + Trace tt <- withConfig (Just val) tr + T.traceWith tt (lc, Just Optimize, m) + _ -> let decidingDict = + foldl + (\acc e -> Map.insertWith (+) e (1 :: Int) acc) + Map.empty + (Map.elems cmap) + (mostCommon, _) = maximumBy + (\(_, n') (_, m') -> compare n' m') + (Map.assocs decidingDict) + newmap = Map.filter (/= mostCommon) cmap + in do + -- trace ("mkTrace Optimize map " <> show (lcNamespace lc) + -- <> " val " <> show mostCommon + -- <> " map " <> show newmap) $ pure () + liftIO $ writeIORef ref (Left (newmap, Just mostCommon)) + Trace tt <- withConfig Nothing tr + T.traceWith tt (lc, Just Optimize, m) + Right _val -> error $ "Trace not reset before reconfiguration (3)" + ++ show (lcNamespace lc) + Left (_cmap, Just _v) -> + error $ "Trace not reset before reconfiguration (4)" + ++ show (lcNamespace lc) + mkTrace ref (lc, Just dc@Document {}, a) = do + eitherConf <- liftIO $ readIORef ref + case eitherConf of + Right val -> do + tt <- withConfig (Just val) tr + T.traceWith + (unpackTrace tt) (lc, Just dc, a) + Left (cmap, Just v) -> + case Map.lookup (lcNamespace lc) cmap of + Just val -> do + tt <- withConfig (Just val) tr + T.traceWith (unpackTrace tt) (lc, Just dc, a) + Nothing -> do + tt <- withConfig (Just v) tr + T.traceWith (unpackTrace tt) (lc, Just dc, a) + Left (_cmap, Nothing) -> error ("Missing configuration(2) " <> name <> " ns " <> show (lcNamespace 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 + "severity" + getSeverity' + (\ mbSev (Trace tr) -> + pure $ Trace $ T.arrow $ T.emit $ + \case + (lc, Just c@Document {}, v) -> do + addFiltered c mbSev + T.traceWith + (unpackTrace (filterTraceBySeverity mbSev (Trace tr))) + (lc, Just c, v) + (lc, mbC, v) -> do + T.traceWith + (unpackTrace (filterTraceBySeverity mbSev (Trace tr))) + (lc, mbC, v)) + +-- | Set detail level of a trace from the config +withDetailsFromConfig :: (MonadIO m) => + Trace m a + -> m (Trace m a) +withDetailsFromConfig = + withNamespaceConfig + "details" + getDetails' + (\mbDtl b -> case mbDtl of + Just dtl -> pure $ setDetails dtl b + Nothing -> pure $ setDetails DNormal b) + +-- | Routing and formatting of a trace from the config +withBackendsFromConfig :: (MonadIO m) => + (Maybe [BackendConfig] -> Trace m FormattedMessage -> m (Trace m a)) + -> m (Trace m a) +withBackendsFromConfig routerAndFormatter = + withNamespaceConfig + "backends" + getBackends' + routerAndFormatter + (Trace T.nullTracer) + +data Limiter m a = Limiter Text Double (Trace m a) + +instance Eq (Limiter m a) where + Limiter t1 _ _ == Limiter t2 _ _ = t1 == t2 + +instance Ord (Limiter m a) where + Limiter t1 _ _ <= Limiter t2 _ _ = t1 <= t2 + +instance Show (Limiter m a) where + show (Limiter name _ _) = "Limiter " <> unpack name + + +-- | Routing and formatting of a trace from the config +withLimitersFromConfig :: forall a m .(MonadUnliftIO m) => + Trace m a + -> Trace m LimitingMessage + -> m (Trace m a) +withLimitersFromConfig tr trl = do + ref <- liftIO $ newIORef Map.empty + withNamespaceConfig + "limiters" + (getLimiter ref) + withLimiter + tr + where + -- | May return a limiter, which is a stateful transformation from trace to trace + getLimiter :: + IORef (Map.Map Text (Limiter m a)) + -> TraceConfig + -> Namespace + -> m (Maybe (Limiter m a)) + getLimiter stateRef config ns = + case getLimiterSpec config ns of + Nothing -> pure Nothing + Just (name, frequency) -> do + state <- liftIO $ readIORef stateRef + case Map.lookup name state of + Just limiter -> pure $ Just limiter + Nothing -> do + limiterTrace <- limitFrequency frequency name tr trl + let limiter = Limiter name frequency limiterTrace + liftIO $ writeIORef stateRef (Map.insert name limiter state) + pure $ Just limiter + + withLimiter :: + Maybe (Maybe (Limiter m a)) + -> Trace m a + -> m (Trace m a) + withLimiter Nothing tr' = pure tr' + withLimiter (Just Nothing) tr' = pure tr' + + + withLimiter (Just (Just (Limiter n d (Trace trli)))) (Trace tr') = + pure $ Trace $ T.arrow $ T.emit $ + \ case + (lc, Nothing, v) -> + T.traceWith trli (lc, Nothing, v) + (lc, Just c@Document {}, v) -> do + addLimiter c (n, d) + T.traceWith tr' (lc, Just c, v) + (lc, Just c, v) -> + T.traceWith tr' (lc, Just c, v) + +-------------------------------------------------------- + +-- | If no severity can be found in the config, it is set to Warning +getSeverity :: TraceConfig -> Namespace -> SeverityF +getSeverity config ns = + fromMaybe WarningF (getOption severitySelector config ns) + where + severitySelector :: ConfigOption -> Maybe SeverityF + severitySelector (CoSeverity s) = Just s + severitySelector _ = Nothing + +getSeverity' :: Applicative m => TraceConfig -> Namespace -> m SeverityF +getSeverity' config ns = pure $ getSeverity config ns + +-- | If no details can be found in the config, it is set to DNormal +getDetails :: TraceConfig -> Namespace -> DetailLevel +getDetails config ns = + fromMaybe DNormal (getOption detailSelector config ns) + where + detailSelector :: ConfigOption -> Maybe DetailLevel + detailSelector (CoDetail d) = Just d + detailSelector _ = Nothing + +getDetails' :: Applicative m => TraceConfig -> Namespace -> m DetailLevel +getDetails' config ns = pure $ getDetails config ns + +-- | If no backends can be found in the config, it is set to +-- [EKGBackend, Forwarder, Stdout HumanFormatColoured] +getBackends :: TraceConfig -> Namespace -> [BackendConfig] +getBackends config ns = + fromMaybe [EKGBackend, Forwarder, Stdout HumanFormatColoured] + (getOption backendSelector config ns) + where + backendSelector :: ConfigOption -> Maybe [BackendConfig] + backendSelector (CoBackend s) = Just s + backendSelector _ = Nothing + +getBackends' :: Applicative m => TraceConfig -> Namespace -> m [BackendConfig] +getBackends' config ns = pure $ getBackends config ns + +-- | May return a limiter specification +getLimiterSpec :: TraceConfig -> Namespace -> Maybe (Text, Double) +getLimiterSpec = getOption limiterSelector + where + limiterSelector :: ConfigOption -> Maybe (Text, Double) + limiterSelector (CoLimiter n f) = Just (n, f) + limiterSelector _ = Nothing + + +-- | Searches in the config to find an option +getOption :: (ConfigOption -> Maybe a) -> TraceConfig -> Namespace -> Maybe a +getOption sel config [] = + case Map.lookup [] (tcOptions config) of + Nothing -> Nothing + Just options -> case mapMaybe sel options of + [] -> Nothing + (opt : _) -> Just opt +getOption sel config ns = + case Map.lookup ns (tcOptions config) of + Nothing -> getOption sel config (init ns) + Just options -> case mapMaybe sel options of + [] -> getOption sel config (init ns) + (opt : _) -> Just opt + +-- ----------------------------------------------------------------------------- +-- Configuration file + +readConfiguration :: FilePath -> IO TraceConfig +readConfiguration fp = + either throwIO pure . parseRepresentation =<< BS.readFile fp + +parseRepresentation :: ByteString -> Either ParseException TraceConfig +parseRepresentation bs = transform (decodeEither' bs) + where + transform :: + Either ParseException ConfigRepresentation + -> Either ParseException TraceConfig + transform (Left e) = Left e + transform (Right rl) = Right $ transform' emptyTraceConfig rl + transform' :: TraceConfig -> ConfigRepresentation -> TraceConfig + transform' (TraceConfig tc _fc _fcc) cr = + let tc' = foldl' (\ tci (TraceOptionSeverity ns severity') -> + let ns' = split (=='.') ns + ns'' = if ns' == [""] then [] else ns' + in Map.insertWith (++) ns'' [CoSeverity severity'] tci) + tc + (traceOptionSeverity cr) + tc'' = foldl' (\ tci (TraceOptionDetail ns detail') -> + let ns' = split (=='.') ns + ns'' = if ns' == [""] then [] else ns' + in Map.insertWith (++) ns'' [CoDetail detail'] tci) + tc' + (traceOptionDetail cr) + tc''' = foldl' (\ tci (TraceOptionBackend ns backend') -> + let ns' = split (=='.') ns + ns'' = if ns' == [""] then [] else ns' + in Map.insertWith (++) ns'' [CoBackend backend'] tci) + tc'' + (traceOptionBackend cr) + tc'''' = foldl' (\ tci (TraceOptionLimiter ns name frequ) -> + let ns' = split (=='.') ns + ns'' = if ns' == [""] then [] else ns' + in Map.insertWith (++) ns'' [CoLimiter name frequ] tci) + tc''' + (traceOptionLimiter cr) + in TraceConfig + tc'''' + (traceOptionForwarder cr) + (traceOptionForwardQueueSize cr) + +data TraceOptionSeverity = TraceOptionSeverity { + nsS :: Text + , severity :: SeverityF + } deriving (Eq, Ord, Show) + +instance AE.ToJSON TraceOptionSeverity where + toJSON tos = object [ "ns" .= nsS tos + , "severity" .= AE.toJSON (severity tos) + ] + +instance AE.FromJSON TraceOptionSeverity where + parseJSON (Object obj) = TraceOptionSeverity + <$> obj .: "ns" + <*> obj .: "severity" + +data TraceOptionDetail = TraceOptionDetail { + nsD :: Text + , detail :: DetailLevel + } deriving (Eq, Ord, Show, Generic) + +instance AE.ToJSON TraceOptionDetail where + toJSON tos = object [ "ns" .= nsD tos + , "detail" .= AE.toJSON (detail tos) + ] + +instance AE.FromJSON TraceOptionDetail where + parseJSON (Object obj) = TraceOptionDetail + <$> obj .: "ns" + <*> obj .: "detail" + +data TraceOptionBackend = TraceOptionBackend { + nsB :: Text + , backends :: [BackendConfig] + } deriving (Eq, Ord, Show, Generic) + +instance AE.ToJSON TraceOptionBackend where + toJSON tos = object [ "ns" .= nsB tos + , "backends" .= AE.toJSON (backends tos) + ] + +instance AE.FromJSON TraceOptionBackend where + parseJSON (Object obj) = TraceOptionBackend + <$> obj .: "ns" + <*> obj .: "backends" + + +data TraceOptionLimiter = TraceOptionLimiter { + nsL :: Text + , limiterName :: Text + , limiterFrequency :: Double + } deriving (Eq, Ord, Show) + +instance AE.ToJSON TraceOptionLimiter where + toJSON tos = object [ "ns" .= nsL tos + , "limiterName" .= limiterName tos + , "limiterFrequency" .= limiterFrequency tos + ] + +instance AE.FromJSON TraceOptionLimiter where + parseJSON (Object obj) = TraceOptionLimiter + <$> obj .: "ns" + <*> obj .: "limiterName" + <*> obj .: "limiterFrequency" + +data ConfigRepresentation = ConfigRepresentation { + traceOptionSeverity :: [TraceOptionSeverity] + , traceOptionDetail :: [TraceOptionDetail] + , traceOptionBackend :: [TraceOptionBackend] + , traceOptionLimiter :: [TraceOptionLimiter] + , traceOptionForwarder :: RemoteAddr + , traceOptionForwardQueueSize :: Int + } + deriving (Eq, Ord, Show) + +instance AE.FromJSON ConfigRepresentation where + parseJSON (Object obj) = ConfigRepresentation + <$> obj .: "TraceOptionSeverity" + <*> obj .: "TraceOptionDetail" + <*> obj .: "TraceOptionBackend" + <*> obj .: "TraceOptionLimiter" + <*> obj .: "TraceOptionForwarder" + <*> obj .: "TraceOptionForwardQueueSize" diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs new file mode 100644 index 00000000000..9311843b08e --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Logging.DocuGenerator ( + documentMarkdown + , buildersToText + , docIt + , addFiltered + , addLimiter + , docTracer +) where + +import Cardano.Logging.Types +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Control.Tracer as T +import Data.Aeson.Text (encodeToLazyText) +import Data.IORef (modifyIORef, newIORef, readIORef) +import Data.List (intersperse, nub, sortBy) +import qualified Data.Map as Map +import Data.Text (Text) +import Data.Text.Internal.Builder (toLazyText) +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (Builder, fromString, fromText, + singleton) +import Data.Time (getZonedTime) + +docTracer :: MonadIO m + => BackendConfig + -> m (Trace m FormattedMessage) +docTracer backendConfig = liftIO $ do + pure $ Trace $ T.arrow $ T.emit output + where + output p@(_, Just Document {}, FormattedMetrics m) = + docIt backendConfig (FormattedMetrics m) p + output (lk, Just c@Document {}, FormattedForwarder lo) = + docIt backendConfig (FormattedHuman False "") (lk, Just c, lo) + output (lk, Just c@Document {}, FormattedHuman co msg) = + docIt backendConfig (FormattedHuman co "") (lk, Just c, msg) + output (lk, Just c@Document {}, FormattedMachine msg) = + docIt backendConfig (FormattedMachine "") (lk, Just c, msg) + output (_, _, _) = pure () + +documentTracers :: MonadIO m => Documented a -> [Trace m a] -> m DocCollector +documentTracers (Documented documented) tracers = do + let docIdx = zip documented [0..] + coll <- fmap DocCollector (liftIO $ newIORef Map.empty) + mapM_ (docTrace docIdx coll) tracers + pure coll + where + docTrace docIdx docColl (Trace tr) = + mapM_ + (\ (DocMsg {..}, idx) -> do + T.traceWith tr (emptyLoggingContext, + Just (Document idx dmMarkdown dmMetricsMD docColl), + dmPrototype)) + docIdx + +addFiltered :: MonadIO m => TraceControl -> Maybe SeverityF -> m () +addFiltered (Document idx mdText mdMetrics (DocCollector docRef)) (Just sev) = do + liftIO $ modifyIORef docRef (\ docMap -> + Map.insert + idx + ((\e -> e { ldFiltered = sev : ldFiltered e}) + (case Map.lookup idx docMap of + Just e -> e + Nothing -> emptyLogDoc mdText mdMetrics)) + docMap) +addFiltered _ _ = pure () + +addLimiter :: MonadIO m => TraceControl -> (Text, Double) -> m () +addLimiter (Document idx mdText mdMetrics (DocCollector docRef)) (ln, lf) = do + liftIO $ modifyIORef docRef (\ docMap -> + Map.insert + idx + ((\e -> e { ldLimiter = (ln, lf) : ldLimiter e}) + (case Map.lookup idx docMap of + Just e -> e + Nothing -> emptyLogDoc mdText mdMetrics)) + docMap) +addLimiter _ _ = pure () + +docIt :: MonadIO m => + BackendConfig + -> FormattedMessage + -> (LoggingContext, Maybe TraceControl, a) + -> m () +docIt backend formattedMessage (LoggingContext {..}, + Just (Document idx mdText mdMetrics (DocCollector docRef)), _msg) = do + liftIO $ modifyIORef docRef (\ docMap -> + Map.insert + idx + ((\e -> e { ldBackends = (backend, formattedMessage) : ldBackends e + , ldNamespace = lcNamespace : ldNamespace e + , ldSeverity = case lcSeverity of + Nothing -> ldSeverity e + Just s -> s : ldSeverity e + , ldPrivacy = case lcPrivacy of + Nothing -> ldPrivacy e + Just s -> s : ldPrivacy e + , ldDetails = case lcDetails of + Nothing -> ldDetails e + Just s -> s : ldDetails e + }) + (case Map.lookup idx docMap of + Just e -> e + Nothing -> emptyLogDoc mdText mdMetrics)) + docMap) + +buildersToText :: [(Namespace, Builder)] -> TraceConfig -> IO Text +buildersToText builderList configuration = do + time <- getZonedTime +-- tz <- getTimeZone + let sortedBuilders = sortBy (\ (l,_) (r,_) -> compare l r) builderList + num = length builderList + content = mconcat $ intersperse (fromText "\n\n") (map snd sortedBuilders) + config = fromString $ "\n\nConfiguration: " <> show configuration + numbers = fromString $ "\n\n" <> show num <> " log messages." + ts = fromString $ "\nGenerated at " <> show time <> "." + pure $ toStrict $ toLazyText (content <> config <> numbers <> ts) + +documentMarkdown :: MonadIO m => + Documented a + -> [Trace m a] + -> m [(Namespace, Builder)] +documentMarkdown (Documented documented) tracers = do + DocCollector docRef <- documentTracers (Documented documented) tracers + items <- fmap Map.toList (liftIO (readIORef docRef)) + let sortedItems = sortBy + (\ (_,l) (_,r) -> compare (ldNamespace l) (ldNamespace r)) + items + pure $ map (\(i, ld) -> case ldNamespace ld of + [] -> (["No Namespace"], documentItem (i, ld)) + (hn:_) -> (hn, documentItem (i, ld))) + sortedItems + where + documentItem :: (Int, LogDoc) -> Builder + documentItem (_idx, ld@LogDoc {..}) = mconcat $ intersperse (fromText "\n\n") + [ namespacesBuilder (nub ldNamespace) + , betweenLines (fromText ldDoc) +-- , representationBuilder (documented `listIndex` idx) + , propertiesBuilder ld + , configBuilder ld + , metricsBuilder ldMetricsDoc (filter fMetrics (nub ldBackends)) + ] + + namespacesBuilder :: [Namespace] -> Builder + namespacesBuilder [ns] = namespaceBuilder ns + namespacesBuilder [] = fromText "__Warning__: Namespace missing" + namespacesBuilder nsl = + mconcat (intersperse (singleton '\n')(map namespaceBuilder nsl)) + + namespaceBuilder :: Namespace -> Builder + namespaceBuilder ns = fromText "### " <> + mconcat (intersperse (singleton '.') (map fromText ns)) + + _representationBuilder :: LogFormatting a => Maybe (DocMsg a) -> Builder + _representationBuilder Nothing = mempty + _representationBuilder (Just DocMsg {..}) = mconcat + $ intersperse (singleton '\n') + [case forHuman dmPrototype of + "" -> mempty + t -> fromText "For human:\n" <> asCode (fromText t) + , let r1 = forMachine DMinimal dmPrototype + r2 = forMachine DNormal dmPrototype + r3 = forMachine DDetailed dmPrototype + in if r1 == mempty && r2 == mempty && r3 == mempty + then mempty + else if r1 == r2 && r2 == r3 + then fromText "For machine:\n" + <> asCode (fromText (toStrict (encodeToLazyText r1))) + else if r1 == r2 + then fromText "For machine regular:\n" + <> asCode (fromText (toStrict (encodeToLazyText r2))) + <> fromText "\nFor machine detailed: " + <> asCode (fromText (toStrict (encodeToLazyText r3))) + else if r2 == r3 + then fromText "For machine brief:\n" + <> asCode (fromText (toStrict (encodeToLazyText r1))) + <> fromText "\nFor machine regular:\n" + <> asCode (fromText (toStrict (encodeToLazyText r2))) + else fromText "For machine brief:\n" + <> asCode (fromText (toStrict (encodeToLazyText r1))) + <> fromText "\nFor machine regular:\n" + <> asCode (fromText (toStrict (encodeToLazyText r2))) + <> fromText "\nFor machine detailed:\n" + <> asCode (fromText (toStrict (encodeToLazyText r3))) + , case asMetrics dmPrototype of + [] -> mempty + l -> mconcat + (intersperse (singleton '\n') + (map + (\case + (IntM ns i) -> + fromText "Integer metrics:\n" + <> asCode (mconcat $ intersperse (singleton '.') + (map fromText ns)) + <> singleton ' ' + <> fromString (show i) + (DoubleM ns i) -> + fromText "Double metrics:\n" + <> asCode (mconcat $ intersperse (singleton '.') + (map fromText ns)) + <> singleton ' ' + <> fromString (show i)) + l)) + ] + + propertiesBuilder :: LogDoc -> Builder + propertiesBuilder LogDoc {..} = + case nub ldSeverity of + [] -> fromText "> Severity: " <> asCode (fromString (show Info)) + [s] -> fromText "> Severity: " <> asCode (fromString (show s)) + l -> fromText "> Severities: " + <> mconcat (intersperse (singleton ',') + (map (asCode . fromString . show) l)) + <> + case nub ldPrivacy of + [] -> fromText "\nPrivacy: " <> asCode (fromString (show Public)) + [p] -> fromText "\nPrivacy: " <> asCode (fromString (show p)) + l -> fromText "\nPrivacies: " + <> mconcat (intersperse (singleton ',') + (map (asCode . fromString . show) l)) + + configBuilder :: LogDoc -> Builder + configBuilder LogDoc {..} = + fromText "From current configuration:\n" + <> case nub ldDetails of + [] -> fromText "Details: " <> asCode (fromString (show DNormal)) + [d] -> fromText "Details: " <> asCode (fromString (show d)) + l -> fromText "Details: " + <> mconcat (intersperse (singleton ',') + (map (asCode . fromString . show) l)) + <> fromText "\n" + <> backendsBuilder (nub ldBackends) + <> fromText "\n" + <> filteredBuilder (nub ldFiltered) (nub ldSeverity) + <> limiterBuilder (nub ldLimiter) + + backendsBuilder :: [(BackendConfig, FormattedMessage)] -> Builder + backendsBuilder [] = fromText "No backends found" + backendsBuilder l = fromText "Backends:\n\t\t\t" + <> mconcat (intersperse (fromText ",\n\t\t\t") + (map backendFormatToText l)) + + backendFormatToText :: (BackendConfig, FormattedMessage) -> Builder + backendFormatToText (be, FormattedMetrics _) = asCode (fromString (show be)) + + backendFormatToText (be, FormattedHuman _c _) = asCode (fromString (show be)) + backendFormatToText (be, FormattedMachine _) = asCode (fromString (show be)) + + filteredBuilder :: [SeverityF] -> [SeverityS] -> Builder + filteredBuilder [] _ = mempty + filteredBuilder l r = + fromText "Filtered: " + <> case (l, r) of + ([lh], [rh]) -> + if fromEnum rh >= fromEnum lh + then (asCode . fromString) "Visible" + else (asCode . fromString) "Invisible" + _ -> mempty + <> fromText " ~ " + <> mconcat (intersperse (fromText ", ") + (map (asCode . fromString . show) l)) + + limiterBuilder :: + [(Text, Double)] + -> Builder + limiterBuilder [] = mempty + limiterBuilder l = + fromText "\nLimiters: " + <> mconcat (intersperse (fromText ", ") + (map (\ (n, d) -> fromText "Limiter " + <> (asCode . fromText) n + <> fromText " with frequency " + <> (asCode . fromString. show) d) + l)) + + fMetrics :: (BackendConfig, FormattedMessage) -> Bool + fMetrics (EKGBackend, FormattedMetrics (_hd:_tl)) = True + fMetrics _ = False + + metricsBuilder :: + Map.Map Namespace Text + -> [(BackendConfig, FormattedMessage)] + -> Builder + metricsBuilder _ [] = mempty + metricsBuilder metricsDoc l = + mconcat $ map (metricsFormatToText metricsDoc) l + + metricsFormatToText :: + Map.Map Namespace Text + -> (BackendConfig, FormattedMessage) + -> Builder + metricsFormatToText metricsDoc (_be, FormattedMetrics l) = + mconcat (intersperse (fromText ",\n") + (map (metricFormatToText metricsDoc) l)) + + metricFormatToText :: Map.Map Namespace Text -> Metric -> Builder + metricFormatToText metricsDoc (IntM ns _) = + fromText "#### _Int metric:_ " + <> mconcat (intersperse (singleton '.') (map fromText ns)) + <> fromText "\n" + <> case Map.lookup ns metricsDoc of + Just "" -> mempty + Just text -> betweenLines (fromText text) + Nothing -> mempty + + metricFormatToText metricsDoc (DoubleM ns _) = + fromText "#### _Double metric:_ " + <> mconcat (intersperse (singleton '.') (map fromText ns)) + <> fromText "\n" + <> case Map.lookup ns metricsDoc of + Just "" -> mempty + Just text -> betweenLines (fromText text) + Nothing -> mempty + metricFormatToText metricsDoc (CounterM ns _) = + fromText "#### _Counter metric:_ " + <> mconcat (intersperse (singleton '.') (map fromText ns)) + <> fromText "\n" + <> case Map.lookup ns metricsDoc of + Just "" -> mempty + Just text -> betweenLines (fromText text) + Nothing -> mempty + +asCode :: Builder -> Builder +asCode b = singleton '`' <> b <> singleton '`' + +betweenLines :: Builder -> Builder +betweenLines b = fromText "\n***\n" <> b <> fromText "\n***\n" + +_listIndex :: [a] -> Int -> Maybe a +_listIndex l i = if i >= length l + then Nothing + else Just (l !! i) diff --git a/trace-dispatcher/src/Cardano/Logging/Formatter.hs b/trace-dispatcher/src/Cardano/Logging/Formatter.hs new file mode 100644 index 00000000000..8fbf796aace --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/Formatter.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Logging.Formatter ( + humanFormatter + , metricsFormatter + , machineFormatter + , forwardFormatter + , preFormatted +) where + +import qualified Control.Tracer as T +import Data.Aeson ((.=)) +import qualified Data.Aeson as AE +import qualified Data.Aeson.Encoding as AE +import qualified Data.ByteString.Lazy as BS +import Data.Functor.Contravariant +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack, stripPrefix) +import Data.Text.Encoding (decodeUtf8) +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder as TB +import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) + +import Cardano.Logging.Types +import Control.Concurrent (myThreadId) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Network.HostName + + +-- | Format this trace as metrics +metricsFormatter + :: forall a m . (LogFormatting a, MonadIO m) + => Text + -> Trace m FormattedMessage + -> m (Trace m a) +metricsFormatter application (Trace tr) = do + let trr = mkTracer + pure $ Trace (T.arrow trr) + where + mkTracer = T.emit $ + \ case + (lc, Nothing, v) -> + let metrics = asMetrics v + in T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} + , Nothing + , FormattedMetrics metrics) + (lc, Just ctrl, v) -> + let metrics = asMetrics v + in T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} + , Just ctrl + , FormattedMetrics metrics) + +-- | Format this trace as TraceObject for the trace forwarder +forwardFormatter + :: forall a m . (LogFormatting a, MonadIO m) + => Text + -> Trace m FormattedMessage + -> m (Trace m a) +forwardFormatter application (Trace tr) = do + hn <- liftIO getHostName + let trr = mkTracer hn + pure $ Trace (T.arrow trr) + where + mkTracer hn = T.emit $ + \ case + (lc, Nothing, v) -> do + thid <- liftIO myThreadId + time <- liftIO getCurrentTime + let fh = forHuman v + details = fromMaybe DNormal (lcDetails lc) + fm = forMachine details v + nlc = lc { lcNamespace = application : lcNamespace lc} + to = TraceObject { + toHuman = if fh == "" then Nothing else Just fh + , toMachine = if fm == mempty then Nothing else + Just $ decodeUtf8 (BS.toStrict (AE.encode fm)) + , toNamespace = lcNamespace nlc + , toSeverity = fromMaybe Info (lcSeverity lc) + , toDetails = fromMaybe DNormal (lcDetails lc) + , toTimestamp = time + , toHostname = hn + , toThreadId = (pack . show) thid + } + T.traceWith tr ( nlc + , Nothing + , FormattedForwarder to) + (lc, Just ctrl, _v) -> do + thid <- liftIO myThreadId + time <- liftIO getCurrentTime + let nlc = lc { lcNamespace = application : lcNamespace lc} + to = TraceObject { + toHuman = Nothing + , toMachine = Nothing + , toNamespace = lcNamespace nlc + , toSeverity = fromMaybe Info (lcSeverity lc) + , toDetails = fromMaybe DNormal (lcDetails lc) + , toTimestamp = time + , toHostname = hn + , toThreadId = (pack . show) thid + } + T.traceWith tr ( nlc + , Just ctrl + , FormattedForwarder to) + +-- | Format this trace for human readability +-- The boolean value tells, if this representation is for the console and should be colored +-- The text argument gives the application name which is prepended to the namespace +humanFormatter + :: forall a m . (LogFormatting a, MonadIO m) + => Bool + -> Text + -> Trace m FormattedMessage + -> m (Trace m a) +humanFormatter withColor application (Trace tr) = do + hn <- liftIO getHostName + let trr = mkTracer hn + pure $ Trace (T.arrow trr) + where + mkTracer hn = T.emit $ + \ case + (lc, Nothing, v) -> do + let fh = forHuman v + text <- liftIO $ formatContextHuman withColor hn application lc fh + T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} + , Nothing + , FormattedHuman withColor text) + (lc, Just ctrl, _v) -> do + T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} + , Just ctrl + , FormattedHuman withColor "") + +formatContextHuman :: + Bool + -> String + -> Text + -> LoggingContext + -> Text + -> IO Text +formatContextHuman withColor hostname application LoggingContext {..} txt = do + thid <- myThreadId + time <- getCurrentTime + let severity = fromMaybe Info lcSeverity + tid = fromMaybe ((pack . show) thid) + ((stripPrefix "ThreadId " . pack . show) thid) + ts = fromString $ formatTime defaultTimeLocale "%F %H:%M:%S%4Q" time + ns = colorBySeverity + withColor + severity + $ fromString hostname + <> singleton ':' + <> mconcat (intersperse (singleton '.') + (map fromText (application : lcNamespace))) + tadd = fromText " (" + <> fromString (show severity) + <> singleton ',' + <> fromText tid + <> fromText ") " + pure $ toStrict + $ toLazyText + $ squareBrackets ts + <> singleton ' ' + <> squareBrackets ns + <> tadd + <> fromText txt + where + squareBrackets :: Builder -> Builder + squareBrackets b = singleton '[' <> b <> singleton ']' + +-- | Format this trace for machine readability +-- The detail level give a hint to the formatter +-- The text argument gives the application name which is prepended to the namespace +machineFormatter + :: forall a m . (LogFormatting a, MonadIO m) + => Text + -> Trace m FormattedMessage + -> m (Trace m a) +machineFormatter application (Trace tr) = do + hn <- liftIO getHostName + let trr = mkTracer hn + pure $ Trace (T.arrow trr) + where + mkTracer hn = T.emit $ + \case + (lc, Nothing, v) -> do + let detailLevel = fromMaybe DNormal (lcDetails lc) + obj <- liftIO $ formatContextMachine hn application lc (forMachine detailLevel v) + T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} + , Nothing + , FormattedMachine (decodeUtf8 (BS.toStrict + (AE.encodingToLazyByteString obj)))) + (lc, Just c, _v) -> do + T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} + , Just c + , FormattedMachine "") + +formatContextMachine :: + String + -> Text + -> LoggingContext + -> AE.Object + -> IO AE.Encoding +formatContextMachine hostname application LoggingContext {..} obj = do + thid <- myThreadId + time <- getCurrentTime + let severity = (pack . show) (fromMaybe Info lcSeverity) + tid = fromMaybe ((pack . show) thid) + ((stripPrefix "ThreadId " . pack . show) thid) + ns = application : lcNamespace + ts = pack $ formatTime defaultTimeLocale "%F %H:%M:%S%4Q" time + pure $ AE.pairs $ "at" .= ts + <> "ns" .= ns + <> "message" .= obj + <> "sev" .= severity + <> "thread" .= tid + <> "host" .= hostname + + +-- | Transform this trace to a preformatted message, so that double serialization +-- is avoided +preFormatted :: + ( LogFormatting a + , Monad m) + => [BackendConfig] + -> Trace m (PreFormatted a) + -> Trace m a +preFormatted backends tr@(Trace tr')= + if Forwarder `elem` backends + then if elem (Stdout HumanFormatUncoloured) backends + || elem (Stdout HumanFormatColoured) backends + then contramap (\msg -> PreFormatted msg (Just (forHuman msg)) Nothing) tr + else if Stdout MachineFormat `elem` backends + then Trace $ T.contramap + (\ (lc, mbC, msg) -> + let dtal = fromMaybe DNormal (lcDetails lc) + in (lc, mbC, PreFormatted msg Nothing (Just (forMachine dtal msg)))) + tr' + else contramap (\msg -> PreFormatted msg Nothing Nothing) tr + else contramap (\msg -> PreFormatted msg Nothing Nothing) tr + +-- | Color a text message based on `Severity`. `Error` and more severe errors +-- are colored red, `Warning` is colored yellow, and all other messages are +-- rendered in the default color. +colorBySeverity :: Bool -> SeverityS -> Builder -> Builder +colorBySeverity withColor severity msg = case severity of + Emergency -> red msg + Alert -> red msg + Critical -> red msg + Error -> red msg + Warning -> yellow msg + _ -> msg + where + red = colorize "31" + yellow = colorize "33" + colorize c s + | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m" + | otherwise = s diff --git a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs new file mode 100644 index 00000000000..2ef77957e24 --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Logging.FrequencyLimiter ( + limitFrequency + , LimitingMessage(..) + , LimiterSpec (..) +)where + +import Control.Monad.IO.Unlift +import qualified Control.Tracer as T +import Data.Aeson (Value (..), (.=)) +import Data.Text (Text, pack) +import Data.Time.Clock.System +import GHC.Generics + +import Cardano.Logging.Trace +import Cardano.Logging.Types + +data LimiterSpec = LimiterSpec { + lsNs :: [Text] + , lsName :: Text + , lsFrequency :: Double +} + +data LimitingMessage = + StartLimiting Text + -- ^ This message indicates the start of frequency limiting + | StopLimiting Text Int + -- ^ This message indicates the stop of frequency limiting, + -- and gives the number of messages that has been suppressed + | RememberLimiting Text Int + -- ^ This message remembers of ongoing frequency limiting, + -- and gives the number of messages that has been suppressed + + deriving (Eq, Ord, Show, Generic) + +instance LogFormatting LimitingMessage where + forHuman (StartLimiting txt) = "Start of frequency limiting for " <> txt + forHuman (StopLimiting txt num) = "Stop of frequency limiting for " <> txt <> + ". Suppressed " <> pack (show num) <> " messages." + forHuman (RememberLimiting txt num) = "Frequency limiting still active for " <> txt <> + ". Suppressed so far " <> pack (show num) <> " messages." + forMachine _dtl (StartLimiting txt) = mkObject + [ "kind" .= String "StartLimiting" + , "name" .= String txt + ] + forMachine _dtl (StopLimiting txt num) = mkObject + [ "kind" .= String "StopLimiting" + , "name" .= String txt + , "numSuppressed" .= Number (fromIntegral num) + ] + forMachine _dtl (RememberLimiting txt num) = mkObject + [ "kind" .= String "RememberLimiting" + , "name" .= String txt + , "numSuppressed" .= Number (fromIntegral num) + ] + asMetrics (StartLimiting _txt) = [] + asMetrics (StopLimiting txt num) = [IntM + ["SuppressedMessages " <> txt] + (fromIntegral num)] + asMetrics (RememberLimiting _txt _num) = [] + +data FrequencyRec a = FrequencyRec { + frMessage :: Maybe a -- ^ The message to pass + , frLastTime :: Double -- ^ The time since the last message did arrive in seconds + , frLastRem :: Double -- ^ The time since the last limiting remainder was send + , frBudget :: Double -- ^ A budget which is used to decide when to start limiting + -- and stop limiting. When messages arrive in shorter frquency then + -- by the given thresholdFrequency budget is spend, and if they + -- arrive in a longer period budget is earned. + -- A value between 1.0 and -1.0. If -1.0 is reached start limiting, + -- and if 1.0 is reached stop limiting. + , frActive :: Maybe (Int, Double) + -- ^ Just is active and carries the number + -- of suppressed messages and the time of last send message +} deriving (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 percentage +-- on the vtracer until the frequency falls under the treshold. + +-- Before this the ltracer gets a StartLimiting message with the +-- current percentage given as a floating point number between 1.0 and 0.0. +-- Inbetween you can receive ContinueLimiting messages on the ltracer, +-- with the current percentage. +-- Finally it sends a StopLimiting message on the ltracer and traces all +-- messages on the vtracer again. +limitFrequency + :: forall a m . (MonadIO m, MonadUnliftIO m) + => Double -- messages per second + -> 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 thresholdFrequency limiterName vtracer ltracer = do + timeNow <- systemTimeToSeconds <$> liftIO getSystemTime +-- trace ("limitFrequency called " <> unpack limiterName) $ pure () + foldMTraceM + (checkLimiting (1.0 / thresholdFrequency)) + (FrequencyRec Nothing timeNow 0.0 0.0 Nothing) + (Trace $ T.contramap unfoldTrace (unpackTrace (filterTraceMaybe vtracer))) + where + checkLimiting :: Double -> FrequencyRec a -> LoggingContext -> a -> m (FrequencyRec a) + checkLimiting thresholdPeriod fs@FrequencyRec {..} lc message = do + -- trace ("Limiter " <> unpack limiterName <> " receives " <> show (lcNamespace lc)) + -- $ pure () + timeNow <- liftIO $ systemTimeToSeconds <$> getSystemTime + let elapsedTime = timeNow - frLastTime + let rawSpendReward = elapsedTime - thresholdPeriod + -- negative if shorter, positive if longer + let normaSpendReward = rawSpendReward * thresholdFrequency -- TODO not really normalized + let spendReward = min 0.5 (max (-0.5) normaSpendReward) + let newBudget = min 1.0 (max (-1.0) (spendReward + frBudget)) + -- trace ("elapsedTime " ++ show elapsedTime + -- ++ " thresholdPeriod " ++ show thresholdPeriod + -- ++ " rawSpendReward " ++ show rawSpendReward + -- ++ " normaSpendReward " ++ show normaSpendReward + -- ++ " spendReward " ++ show spendReward + -- ++ " newBudget " ++ show newBudget $ + case frActive of + Nothing -> -- not active + if spendReward + frBudget <= -1.0 + then do -- start limiting + traceWith + (setSeverity Info (withLoggingContext lc ltracer)) + (StartLimiting limiterName) + pure fs { frMessage = Just message + , frLastTime = timeNow + , frLastRem = timeNow + , frBudget = newBudget + , frActive = Just (0, timeNow) + } + else -- continue without limiting + pure fs { frMessage = Just message + , frLastTime = timeNow + , frLastRem = 0.0 + , frBudget = newBudget + } + Just (nSuppressed, lastTimeSend) -> -- is active + if spendReward + frBudget >= 1.0 + then do -- stop limiting + traceWith + (setSeverity Info (withLoggingContext lc ltracer)) + (StopLimiting limiterName nSuppressed) + pure fs { frMessage = Just message + , frLastTime = timeNow + , frBudget = newBudget + , frActive = Nothing + } + else + let lastPeriod = timeNow - lastTimeSend + lastReminder = timeNow - frLastRem + in do + newFrLastRem <- if lastReminder > 15.0 -- send out every 15 seconds + then do + traceWith + (setSeverity Info + (withLoggingContext lc ltracer)) + (RememberLimiting limiterName nSuppressed) + pure timeNow + else pure frLastRem + -- trace ("lastPeriod " ++ show lastPeriod + -- ++ " thresholdPeriod " ++ show thresholdPeriod) $ + if lastPeriod > thresholdPeriod + then -- send + pure fs { frMessage = Just message + , frLastTime = timeNow + , frLastRem = newFrLastRem + , frBudget = newBudget + , frActive = Just (nSuppressed, timeNow) + } + else -- suppress + pure fs { frMessage = Nothing + , frLastTime = timeNow + , frLastRem = newFrLastRem + , frBudget = newBudget + , frActive = Just (nSuppressed + 1, lastTimeSend) + } + unfoldTrace :: + (LoggingContext, Maybe TraceControl, Folding a (FrequencyRec a)) + -> (LoggingContext, Maybe TraceControl, Maybe a) + unfoldTrace (lc, mbC, Folding FrequencyRec {..}) = (lc, mbC, frMessage) + + systemTimeToSeconds :: SystemTime -> Double + systemTimeToSeconds MkSystemTime {..} = + fromIntegral systemSeconds + fromIntegral systemNanoseconds * 1.0E-9 diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs new file mode 100644 index 00000000000..63c27161ceb --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/Trace.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + + +module Cardano.Logging.Trace ( + traceNamed + , traceWith + , filterTrace + , filterTraceMaybe + , filterTraceBySeverity + , withLoggingContext + , appendName + , withNamesAppended + , setSeverity + , withSeverity + , privately + , setPrivacy + , withPrivacy + , allPublic + , allConfidential + , filterTraceByPrivacy + , setDetails + , withDetails + , foldTraceM + , foldMTraceM + , routingTrace +) + +where + +import Control.Monad (join) +import Control.Monad.IO.Unlift +import qualified Control.Tracer as T +import Data.Maybe (isJust) +import Data.Text (Text) +import UnliftIO.MVar + +import Cardano.Logging.Types + +-- | Adds a message object to a trace +traceWith :: Monad m => Trace m a -> a -> m () +traceWith (Trace tr) a = + T.traceWith tr (emptyLoggingContext, Nothing, a) + +-- | Convenience function for tracing a message with a name +-- As the simple name suggest, this should be the standard function +traceNamed :: Monad m => Trace m a -> Text -> a -> m () +traceNamed tr n = traceWith (appendName n tr) + +--- | Don't process further if the result of the selector function +--- is False. +filterTrace :: (Monad m) => + ((LoggingContext, Maybe TraceControl, a) -> Bool) + -> Trace m a + -> Trace m a +filterTrace ff (Trace tr) = Trace $ T.squelchUnless + (\case + (_lc, Just _, _a) -> True + (lc, mbC, a) -> ff (lc, mbC, a)) + tr + +--- | Keep the Just values and forget about the Nothings +filterTraceMaybe :: Monad m => + Trace m a + -> Trace m (Maybe a) +filterTraceMaybe (Trace tr) = Trace $ + T.squelchUnless + (\case + (_lc, _mbC, Just _a) -> True + (_lc, _mbC, Nothing) -> False) + (T.contramap + (\case + (lc, mbC, Just a) -> (lc, mbC, a) + (_lc, _mbC, Nothing) -> error "filterTraceMaybe: impossible") + tr) + +--- | Only processes messages further with a severity equal or greater as the +--- given one +filterTraceBySeverity :: Monad m => + Maybe SeverityF + -> Trace m a + -> Trace m a +filterTraceBySeverity (Just minSeverity) = + filterTrace $ + \case + (_lc, Just _, _a) -> True + (lc, _, _e) -> + case lcSeverity lc of + Just s -> fromEnum s >= fromEnum minSeverity + Nothing -> True +filterTraceBySeverity Nothing = id + +-- | Sets a new logging context for this message +withLoggingContext :: Monad m => LoggingContext -> Trace m a -> Trace m a +withLoggingContext lc (Trace tr) = Trace $ + T.contramap + (\ + (_lc, mbC, e) -> (lc, mbC, e)) + tr + +-- | Appends a name to the context. +-- E.g. appendName "specific" $ appendName "middle" $ appendName "general" tracer +-- give the result: `general.middle.specific`. +appendName :: Monad m => Text -> Trace m a -> Trace m a +appendName name (Trace tr) = Trace $ + T.contramap + (\ + (lc, mbC, e) -> (lc {lcNamespace = name : lcNamespace lc}, mbC, e)) + tr + +-- | Sets names for the messages in this trace based on the selector function +withNamesAppended :: Monad m => (a -> [Text]) -> Trace m a -> Trace m a +withNamesAppended func (Trace tr) = Trace $ + T.contramap + (\ + (lc, mbC, e) -> (lc {lcNamespace = func e ++ lcNamespace lc}, mbC, e)) + tr + +-- | Sets severity for the messages in this trace +setSeverity :: Monad m => SeverityS -> Trace m a -> Trace m a +setSeverity s (Trace tr) = Trace $ T.contramap + (\ (lc, mbC, e) -> if isJust (lcSeverity lc) + then (lc, mbC, e) + else (lc {lcSeverity = Just s}, mbC, e)) + tr + +-- | Sets severities for the messages in this trace based on the selector function +withSeverity :: Monad m => (a -> SeverityS) -> Trace m a -> Trace m a +withSeverity fs (Trace tr) = Trace $ + T.contramap + (\ + (lc, mbC, e) -> if isJust (lcSeverity lc) + then (lc, mbC, e) + else (lc {lcSeverity = Just (fs e)}, mbC, e)) + tr + +--- | Only processes messages further with a privacy greater then the given one +filterTraceByPrivacy :: (Monad m) => + Maybe Privacy + -> Trace m a + -> Trace m a +filterTraceByPrivacy (Just minPrivacy) = filterTrace $ + \case + (_lc, Just _, _a) -> True + (c, _mbC, _e) -> + case lcPrivacy c of + Just s -> fromEnum s >= fromEnum minPrivacy + Nothing -> True +filterTraceByPrivacy Nothing = id + +allPublic :: a -> Privacy +allPublic _ = Public + +allConfidential :: a -> Privacy +allConfidential _ = Confidential + + +-- | Sets privacy Confidential for the messages in this trace +privately :: Monad m => Trace m a -> Trace m a +privately = setPrivacy Confidential + +-- | Sets privacy for the messages in this trace +setPrivacy :: Monad m => Privacy -> Trace m a -> Trace m a +setPrivacy p (Trace tr) = Trace $ + T.contramap + (\ (lc, mbC, v) -> if isJust (lcPrivacy lc) + then (lc, mbC, v) + else (lc {lcPrivacy = Just p}, mbC, v)) + tr + +-- | Sets privacy for the messages in this trace based on the message +withPrivacy :: Monad m => (a -> Privacy) -> Trace m a -> Trace m a +withPrivacy fs (Trace tr) = Trace $ + T.contramap + (\ (lc, mbC, e) -> if isJust (lcPrivacy lc) + then (lc, mbC, e) + else (lc {lcPrivacy = Just (fs e)}, mbC, e)) + tr + +-- | Sets detail level for the messages in this trace +setDetails :: Monad m => DetailLevel -> Trace m a -> Trace m a +setDetails p (Trace tr) = Trace $ + T.contramap + (\ (lc, mbC, v) -> if isJust (lcDetails lc) + then (lc, mbC, v) + else (lc {lcDetails = Just p}, mbC, v)) + tr + +-- | Sets detail level for the messages in this trace based on the message +withDetails :: Monad m => (a -> DetailLevel) -> Trace m a -> Trace m a +withDetails fs (Trace tr) = Trace $ + T.contramap + (\ + (lc, mbC, e) -> if isJust (lcDetails lc) + then (lc, mbC, e) + else (lc {lcDetails = Just (fs e)}, mbC, e)) + tr + +-- | Folds the cata function with acc over a. +-- Uses an MVar to store the state +foldTraceM + :: forall a acc m . (MonadUnliftIO m) + => (acc -> LoggingContext -> a -> acc) + -> acc + -> Trace m (Folding a acc) + -> m (Trace m a) +foldTraceM cata initial (Trace tr) = do + ref <- liftIO (newMVar initial) + let trr = mkTracer ref + pure $ Trace (T.Tracer trr) + where + mkTracer ref = T.emit $ + \case + (lc, Nothing, v) -> do + x' <- modifyMVar ref $ \x -> + let ! accu = cata x lc v + in pure $ join (,) accu + T.traceWith tr (lc, Nothing, Folding x') + (lc, Just control, _v) -> do + T.traceWith tr (lc, Just control, Folding initial) + +-- | Folds the monadic cata function with acc over a. +-- Uses an IORef to store the state +foldMTraceM + :: forall a acc m . (MonadUnliftIO m) + => (acc -> LoggingContext -> a -> m acc) + -> acc + -> Trace m (Folding a acc) + -> m (Trace m a) +foldMTraceM cata initial (Trace tr) = do + ref <- liftIO (newMVar initial) + let trr = mkTracer ref + pure $ Trace (T.arrow trr) + where + mkTracer ref = T.emit $ + \case + (lc, Nothing, v) -> do + x' <- modifyMVar ref $ \x -> do + ! accu <- cata x lc v + pure $ join (,) accu + T.traceWith tr (lc, Nothing, Folding x') + (lc, Just control, _v) -> do + T.traceWith tr (lc, Just control, Folding initial) + +-- | Allows to route to different tracers, based on the message being processed. +-- The second argument must mappend all possible tracers of the first +-- argument to one tracer. This is required for the configuration! +routingTrace + :: forall m a. Monad m + => (a -> m (Trace m a)) + -> Trace m a + -> m (Trace m a) +routingTrace rf rc = pure $ Trace $ T.arrow $ T.emit $ + \case + (lc, Nothing, a) -> do + nt <- rf a + T.traceWith (unpackTrace nt) (lc, Nothing, a) + (lc, Just control, a) -> + T.traceWith (unpackTrace rc) (lc, Just control, a) diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs new file mode 100644 index 00000000000..40b8e58bda8 --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Logging.Tracer.Composed ( + mkCardanoTracer + , mkCardanoTracer' + ) where + +import Data.Maybe (fromMaybe) +import Data.Text + +import Cardano.Logging.Configuration +import Cardano.Logging.Formatter +import Cardano.Logging.FrequencyLimiter (LimitingMessage (..)) +import Cardano.Logging.Trace +import Cardano.Logging.Types + +import qualified Control.Tracer as NT + +data MessageOrLimit m = Message m | Limit LimitingMessage + +instance (LogFormatting m) => LogFormatting (MessageOrLimit m) where + forMachine dtal (Message m) = forMachine dtal m + forMachine dtal (Limit m) = forMachine dtal m + forHuman (Message m) = forHuman m + forHuman (Limit m) = forHuman m + asMetrics (Message m) = asMetrics m + asMetrics (Limit m) = asMetrics m + +-- | Construct a tracer according to the requirements for cardano node. +-- +-- The tracer gets a 'name', which is appended to its namespace. +-- +-- The tracer gets a 'namesFor', 'severityFor' and 'privacyFor' function +-- as arguments, to set the logging context accordingly. +-- +-- The tracer gets the backends: 'trStdout', 'trForward' and 'mbTrEkg' +-- as arguments. +-- +-- The returned tracer need to be configured for the specification of +-- filtering, detailLevel, frequencyLimiting and backends with formatting before use. +mkCardanoTracer :: forall evt. + LogFormatting evt + => Trace IO FormattedMessage + -> Trace IO FormattedMessage + -> Maybe (Trace IO FormattedMessage) + -> Text + -> (evt -> [Text]) + -> (evt -> SeverityS) + -> (evt -> Privacy) + -> IO (Trace IO evt) +mkCardanoTracer trStdout trForward mbTrEkg name namesFor severityFor privacyFor = + mkCardanoTracer' trStdout trForward mbTrEkg name namesFor severityFor + privacyFor noHook + where + noHook :: Trace IO evt -> IO (Trace IO evt) + noHook tr = pure tr + +-- | Adds the possibility to add special tracers via the hook function +mkCardanoTracer' :: forall evt evt1. + LogFormatting evt1 + => Trace IO FormattedMessage + -> Trace IO FormattedMessage + -> Maybe (Trace IO FormattedMessage) + -> Text + -> (evt -> [Text]) + -> (evt -> SeverityS) + -> (evt -> Privacy) + -> (Trace IO evt1 -> IO (Trace IO evt)) + -> IO (Trace IO evt) +mkCardanoTracer' trStdout trForward mbTrEkg name namesFor severityFor privacyFor + hook = do + tr <- withBackendsFromConfig backendsAndFormat + tr' <- withLimitersFromConfig (NT.contramap Message tr) (NT.contramap Limit tr) + tr'' <- hook tr' + addContextAndFilter tr'' + where + addContextAndFilter :: Trace IO evt -> IO (Trace IO evt) + addContextAndFilter tr = do + tr' <- withDetailsFromConfig tr + tr'' <- filterSeverityFromConfig tr' + pure $ withNamesAppended namesFor + $ appendName name + $ appendName "Node" + $ withSeverity severityFor + $ withPrivacy privacyFor + tr'' + + backendsAndFormat :: + Maybe [BackendConfig] + -> Trace m x + -> IO (Trace IO (MessageOrLimit evt1)) + backendsAndFormat mbBackends _ = + let backends = fromMaybe + [EKGBackend, Forwarder, Stdout HumanFormatColoured] + mbBackends + in do + mbEkgTrace <- case mbTrEkg of + Nothing -> pure Nothing + Just ekgTrace -> + if EKGBackend `elem` backends + then fmap Just + (metricsFormatter "Cardano" ekgTrace) + else pure Nothing + mbForwardTrace <- if Forwarder `elem` backends + then fmap (Just . filterTraceByPrivacy (Just Public)) + (forwardFormatter "Cardano" trForward) + else pure Nothing + mbStdoutTrace <- if Stdout HumanFormatColoured `elem` backends + then fmap Just + (humanFormatter True "Cardano" trStdout) + else if Stdout HumanFormatUncoloured `elem` backends + then fmap Just + (humanFormatter False "Cardano" trStdout) + else if Stdout MachineFormat `elem` backends + then fmap Just + (machineFormatter "Cardano" trStdout) + else pure Nothing + case mbEkgTrace <> mbForwardTrace <> mbStdoutTrace of + Nothing -> pure $ Trace NT.nullTracer + Just tr -> pure (preFormatted backends tr) diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs new file mode 100644 index 00000000000..973e3958b07 --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Logging.Tracer.EKG ( + ekgTracer +) where + +import Cardano.Logging.DocuGenerator +import Cardano.Logging.Types + +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Control.Tracer as T +import Data.IORef (newIORef, readIORef, writeIORef) +import qualified Data.Map.Strict as Map +import Data.Text (intercalate, pack) +import qualified System.Metrics as Metrics +import qualified System.Metrics.Counter as Counter +import qualified System.Metrics.Gauge as Gauge +import qualified System.Metrics.Label as Label +import System.Remote.Monitoring (Server, getCounter, getGauge, + getLabel) + + +ekgTracer :: MonadIO m => Either Metrics.Store Server-> m (Trace m FormattedMessage) +ekgTracer storeOrServer = liftIO $ do + rgsGauges <- newIORef Map.empty + rgsLabels <- newIORef Map.empty + rgsCounters <- newIORef Map.empty + pure $ Trace $ T.arrow $ T.emit $ + output rgsGauges rgsLabels rgsCounters + where + output rgsGauges rgsLabels rgsCounters + (LoggingContext{..}, Nothing, FormattedMetrics m) = + liftIO $ mapM_ + (setIt rgsGauges rgsLabels rgsCounters lcNamespace) m + output _ _ _ p@(_, Just Document {}, FormattedMetrics m) = + docIt EKGBackend (FormattedMetrics m) p + output _ _ _ (LoggingContext{}, Just _c, _v) = + pure () + + setIt rgsGauges _rgsLabels _rgsCounters _namespace + (IntM ns theInt) = do + rgsMap <- readIORef rgsGauges + let name = intercalate "." ns + case Map.lookup name rgsMap of + Just gauge -> Gauge.set gauge (fromIntegral theInt) + Nothing -> do + gauge <- case storeOrServer of + Left store -> Metrics.createGauge name store + Right server -> getGauge name server + let rgsGauges' = Map.insert name gauge rgsMap + writeIORef rgsGauges rgsGauges' + Gauge.set gauge (fromIntegral theInt) + setIt _rgsGauges rgsLabels _rgsCounters _namespace + (DoubleM ns theDouble) = do + rgsMap <- readIORef rgsLabels + let name = intercalate "." ns + case Map.lookup name rgsMap of + Just label -> Label.set label ((pack . show) theDouble) + Nothing -> do + label <- case storeOrServer of + Left store -> Metrics.createLabel name store + Right server -> getLabel name server + let rgsLabels' = Map.insert name label rgsMap + writeIORef rgsLabels rgsLabels' + Label.set label ((pack . show) theDouble) + setIt _rgsGauges _rgsLabels rgsCounters _namespace + (CounterM ns mbInt) = do + rgsMap <- readIORef rgsCounters + let name = intercalate "." ns + case Map.lookup name rgsMap of + Just counter -> case mbInt of + Nothing -> Counter.inc counter + Just i -> Counter.add counter (fromIntegral i) + Nothing -> do + counter <- case storeOrServer of + Left store -> Metrics.createCounter name store + Right server -> getCounter name server + let rgsCounters' = Map.insert name counter rgsMap + writeIORef rgsCounters rgsCounters' + case mbInt of + Nothing -> Counter.inc counter + Just i -> Counter.add counter (fromIntegral i) diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs new file mode 100644 index 00000000000..95e2d1fa5b4 --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Logging.Tracer.Forward + ( + forwardTracer + ) where + +import Codec.CBOR.Term (Term) +import Codec.Serialise (Serialise (..)) +import Control.Concurrent.Async (race_, wait, withAsync) +import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, + writeTBQueue) +import Control.Monad.IO.Class +import Control.Monad.STM (atomically) +import GHC.Generics (Generic) + +import qualified Control.Tracer as T +import "contra-tracer" Control.Tracer (contramap, stdoutTracer) +import qualified Data.ByteString.Lazy as LBS +import Data.Void (Void) +import Data.Word (Word16) + +import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits) +import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) +import Ouroboros.Network.IOManager (IOManager) +import Ouroboros.Network.Mux (MiniProtocol (..), + MiniProtocolLimits (..), MiniProtocolNum (..), + MuxMode (..), OuroborosApplication (..), + RunMiniProtocol (..), miniProtocolLimits, miniProtocolNum, + miniProtocolRun) +import Ouroboros.Network.Protocol.Handshake.Codec + (cborTermVersionDataCodec, noTimeLimitsHandshake) +import Ouroboros.Network.Protocol.Handshake.Type (Handshake) +import Ouroboros.Network.Protocol.Handshake.Unversioned + (UnversionedProtocol (..), UnversionedProtocolData (..), + unversionedHandshakeCodec, unversionedProtocolDataCodec) +import Ouroboros.Network.Protocol.Handshake.Version + (acceptableVersion, simpleSingletonVersions) +import Ouroboros.Network.Snocket (Snocket, localAddressFromPath, + localSnocket) +import Ouroboros.Network.Socket (AcceptedConnectionsLimit (..), + SomeResponderApplication (..), cleanNetworkMutableState, + newNetworkMutableState, nullNetworkServerTracers, + withServerNode) +import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) + +import qualified System.Metrics as EKG +import qualified System.Metrics.Configuration as EKGF +import System.Metrics.Network.Forwarder (forwardEKGMetricsResp) +import qualified Trace.Forward.Configuration as TF +import Trace.Forward.Network.Forwarder (forwardTraceObjectsResp) +import Trace.Forward.Protocol.Type (NodeInfo (..)) +import Trace.Forward.Utils (runActionInLoop) + +import Cardano.Logging.DocuGenerator +import Cardano.Logging.Types + +-- Instances for 'TraceObject' to forward it using 'trace-forward' library. + +deriving instance Generic Privacy +deriving instance Generic SeverityS +deriving instance Generic LoggingContext +deriving instance Generic TraceObject + +instance Serialise DetailLevel +instance Serialise Privacy +instance Serialise SeverityS +instance Serialise LoggingContext +instance Serialise TraceObject + +instance ShowProxy TraceObject + +--------------------------------------------------------------------------- + +-- newtype ForwardTracerState = ForwardTracerState { +-- ftQueue :: TBQueue TraceObject +-- } + +forwardTracer :: forall m. (MonadIO m) + => IOManager + -> TraceConfig + -> NodeInfo + -> m (Trace m FormattedMessage) +forwardTracer iomgr config nodeInfo = liftIO $ do + tbQueue <- newTBQueueIO (fromIntegral (tcForwarderQueueSize config)) + store <- EKG.newStore + EKG.registerGcMetrics store + launchForwarders iomgr (tcForwarder config) nodeInfo tbQueue store +-- stateRef <- liftIO $ newIORef (ForwardTracerState tbQueue) + pure $ Trace $ T.arrow $ T.emit $ uncurry3 (output tbQueue) + where + output :: + TBQueue TraceObject + -> LoggingContext + -> Maybe TraceControl + -> FormattedMessage + -> m () + output tbQueue LoggingContext {} Nothing (FormattedForwarder lo) = liftIO $ do + atomically $ writeTBQueue tbQueue lo + output _tbQueue LoggingContext {} (Just Reset) _msg = liftIO $ do + pure () + output _tbQueue lk (Just c@Document {}) (FormattedForwarder lo) = do + docIt Forwarder (FormattedHuman False "") (lk, Just c, lo) + output _tbQueue LoggingContext {} _ _a = pure () + +launchForwarders + :: IOManager + -> RemoteAddr + -> NodeInfo + -> TBQueue TraceObject + -> EKG.Store + -> IO () +launchForwarders iomgr ep@(LocalSocket p) nodeInfo tbQueue store = flip + withAsync + wait + $ runActionInLoop + (launchForwardersViaLocalSocket iomgr ep (ekgConfig, tfConfig) tbQueue store) + (TF.LocalPipe p) + 1 + where + ekgConfig :: EKGF.ForwarderConfiguration + ekgConfig = + EKGF.ForwarderConfiguration + { EKGF.forwarderTracer = contramap show stdoutTracer + , EKGF.acceptorEndpoint = EKGF.LocalPipe p + , EKGF.reConnectFrequency = 1.0 + , EKGF.actionOnRequest = const $ pure () + } + + tfConfig :: TF.ForwarderConfiguration TraceObject + tfConfig = + TF.ForwarderConfiguration + { TF.forwarderTracer = contramap show stdoutTracer + , TF.acceptorEndpoint = TF.LocalPipe p + , TF.getNodeInfo = pure nodeInfo + } + +launchForwardersViaLocalSocket + :: IOManager + -> RemoteAddr + -> (EKGF.ForwarderConfiguration, TF.ForwarderConfiguration TraceObject) + -> TBQueue TraceObject + -> EKG.Store + -> IO () +launchForwardersViaLocalSocket iomgr (LocalSocket localSock) configs tbQueue store = do + let snocket = localSnocket iomgr localSock + address = localAddressFromPath localSock + doListenToAcceptor snocket address noTimeLimitsHandshake configs tbQueue store + +doListenToAcceptor + :: Ord addr + => Snocket IO fd addr + -> addr + -> ProtocolTimeLimits (Handshake UnversionedProtocol Term) + -> (EKGF.ForwarderConfiguration, TF.ForwarderConfiguration TraceObject) + -> TBQueue TraceObject + -> EKG.Store + -> IO () +doListenToAcceptor snocket address timeLimits (ekgConfig, tfConfig) tbQueue store = do + networkState <- newNetworkMutableState + race_ (cleanNetworkMutableState networkState) + $ withServerNode + snocket + nullNetworkServerTracers + networkState + (AcceptedConnectionsLimit maxBound maxBound 0) + address + unversionedHandshakeCodec + timeLimits + (cborTermVersionDataCodec unversionedProtocolDataCodec) + acceptableVersion + (simpleSingletonVersions + UnversionedProtocol + UnversionedProtocolData + (SomeResponderApplication $ + forwarderApp [ (forwardEKGMetricsResp ekgConfig store, 1) + , (forwardTraceObjectsResp tfConfig tbQueue, 2) + ] + ) + ) + nullErrorPolicies + $ \_ serverAsync -> + wait serverAsync -- Block until async exception. + where + forwarderApp + :: [(RunMiniProtocol 'ResponderMode LBS.ByteString IO Void (), Word16)] + -> OuroborosApplication 'ResponderMode addr LBS.ByteString IO Void () + forwarderApp protocols = + OuroborosApplication $ \_connectionId _shouldStopSTM -> + [ MiniProtocol + { miniProtocolNum = MiniProtocolNum num + , miniProtocolLimits = MiniProtocolLimits { maximumIngressQueue = maxBound } + , miniProtocolRun = prot + } + | (prot, num) <- protocols + ] + +-- | Converts a curried function to a function on a triple. +uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) +uncurry3 f ~(a,b,c) = f a b c diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs new file mode 100644 index 00000000000..3578d85726b --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Logging.Tracer.Standard ( + standardTracer +) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan.Unagi.Bounded +import Control.Monad (forever) +import Control.Monad.IO.Class +import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import GHC.Conc (ThreadId) +import System.IO (hFlush, stdout) + +import Cardano.Logging.DocuGenerator +import Cardano.Logging.Types + +import qualified Control.Tracer as T + +-- | Do we log to stdout or to a file? +data LogTarget = LogStdout | LogFile FilePath + deriving (Eq, Show) + +-- | The state of a standard tracer +data StandardTracerState a = StandardTracerState { + stRunning :: Maybe (InChan Text, OutChan Text, ThreadId) + , stTarget :: LogTarget +} + +emptyStandardTracerState :: Maybe FilePath -> StandardTracerState a +emptyStandardTracerState Nothing = StandardTracerState Nothing LogStdout +emptyStandardTracerState (Just fp) = StandardTracerState Nothing (LogFile fp) + + +standardTracer :: forall m. (MonadIO m) + => Maybe FilePath + -> m (Trace m FormattedMessage) +standardTracer mbFilePath = do + stateRef <- liftIO $ newIORef (emptyStandardTracerState mbFilePath) + pure $ Trace $ T.arrow $ T.emit $ uncurry3 (output stateRef) + where + output :: + IORef (StandardTracerState a) + -> LoggingContext + -> Maybe TraceControl + -> FormattedMessage + -> m () + output stateRef LoggingContext {} Nothing (FormattedHuman _c msg) = liftIO $ do + st <- readIORef stateRef + case stRunning st of + Just (inChannel, _, _) -> writeChan inChannel msg + Nothing -> pure () + output stateRef LoggingContext {} Nothing (FormattedMachine msg) = liftIO $ do + st <- readIORef stateRef + case stRunning st of + Just (inChannel, _, _) -> writeChan inChannel msg + Nothing -> pure () + output stateRef LoggingContext {} (Just Reset) _msg = liftIO $ do + st <- readIORef stateRef + case stRunning st of + Nothing -> initLogging stateRef + Just _ -> pure () + output _ lk (Just c@Document {}) (FormattedHuman co msg) = + docIt + (Stdout (if co then HumanFormatColoured else HumanFormatUncoloured)) + (FormattedHuman co "") + (lk, Just c, msg) + output _ lk (Just c@Document {}) (FormattedMachine msg) = + docIt (Stdout MachineFormat) (FormattedMachine "") (lk, Just c, msg) + output _stateRef LoggingContext {} _ _a = pure () + +-- TODO: care about reconfiguration +initLogging :: IORef (StandardTracerState a) -> IO () +initLogging stateRef = do + (inChan, outChan) <- newChan 2048 + threadId <- forkIO $ forever $ do + msg <- readChan outChan + state <- readIORef stateRef + case stTarget state of + LogFile f -> do + TIO.appendFile f msg + TIO.appendFile f "\n" + LogStdout -> do + TIO.putStrLn msg + hFlush stdout + modifyIORef stateRef (\ st -> + st {stRunning = Just (inChan, outChan, threadId)}) + +-- | Converts a curried function to a function on a triple. +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f ~(a,b,c) = f a b c diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs new file mode 100644 index 00000000000..0e9d67598ea --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Cardano.Logging.Types ( + Trace(..) + , LogFormatting(..) + , Metric(..) + , mkObject + , emptyObject + , Documented(..) + , DocMsg(..) + , LoggingContext(..) + , emptyLoggingContext + , Namespace + , DetailLevel(..) + , Privacy(..) + , SeverityS(..) + , SeverityF(..) + , ConfigOption(..) + , RemoteAddr(..) + , FormatLogging(..) + , TraceConfig(..) + , emptyTraceConfig + , FormattedMessage(..) + , TraceControl(..) + , DocCollector(..) + , LogDoc(..) + , emptyLogDoc + , BackendConfig(..) + , Folding(..) + , unfold + , TraceObject(..) + , PreFormatted(..) +) where + +import Control.Tracer +import qualified Control.Tracer as T +import Data.Aeson ((.=)) +import qualified Data.Aeson as AE +import qualified Data.Aeson.Text as AE +import qualified Data.HashMap.Strict as HM +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text, pack) +import Data.Text.Lazy (toStrict) +import Data.Time (UTCTime) +import GHC.Generics +import Network.HostName (HostName) + +-- | The Trace carries the underlying tracer Tracer from the contra-tracer package. +-- It adds a 'LoggingContext' and maybe a 'TraceControl' to every message. +newtype Trace m a = Trace + {unpackTrace :: Tracer m (LoggingContext, Maybe TraceControl, a)} + +-- | Contramap lifted to Trace +instance Monad m => Contravariant (Trace m) where + contramap f (Trace tr) = Trace $ + T.contramap (\ (lc, mbC, a) -> (lc, mbC, f a)) tr + +-- | @tr1 <> tr2@ will run @tr1@ and then @tr2@ with the same input. +instance Monad m => Semigroup (Trace m a) where + Trace a1 <> Trace a2 = Trace (a1 <> a2) + +instance Monad m => Monoid (Trace m a) where + mappend = (<>) + mempty = Trace T.nullTracer + +-- | Every message needs this to define how to represent itself +class LogFormatting a where + -- | Machine readable representation with the possibility to represent + -- with different details based on the detail level. + -- No machine readable representation as default + forMachine :: DetailLevel -> a -> AE.Object + + -- | Human readable representation. + -- No human representation is represented by the empty text + -- The default implementation returns no human representation + forHuman :: a -> Text + forHuman v = toStrict (AE.encodeToLazyText (forMachine DNormal v)) + + -- | Metrics representation. + -- No metrics by default + asMetrics :: a -> [Metric] + asMetrics _v = [] + +data Metric + -- | An integer metric. + -- If the text array is not empty it is used as namespace namespace + = IntM Namespace Integer + -- | A double metric. + -- If the text array is not empty it is used as namespace + | DoubleM Namespace Double + -- | An counter metric. + -- If the text array is not empty it is used as namespace namespace + | CounterM Namespace (Maybe Int) + deriving (Show, Eq) + +-- | A helper function for creating an |Object| given a list of pairs, named items, +-- or the empty |Object|. +mkObject :: [(Text, a)] -> HM.HashMap Text a +mkObject = HM.fromList + +-- | A helper function for creating an empty |Object|. +emptyObject :: HM.HashMap Text a +emptyObject = HM.empty + +-- Document all log messages by providing a list of DocMsgs 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 configuration. +-- If you don't want to add an item for documentation enter an empty text. +newtype Documented a = Documented {undoc :: [DocMsg a]} + deriving Show + +-- | A unique identifier for every message, composed of text +type Namespace = [Text] + +-- | Document a message by giving a prototype, its most special name in the namespace +-- and a comment in markdown format +data DocMsg a = DocMsg { + dmPrototype :: a + , dmMetricsMD :: [(Namespace, Text)] + , dmMarkdown :: Text +} deriving (Show) + +-- | Context any log message carries +data LoggingContext = LoggingContext { + lcNamespace :: Namespace + , lcSeverity :: Maybe SeverityS + , lcPrivacy :: Maybe Privacy + , lcDetails :: Maybe DetailLevel + } deriving (Eq, Show) + +emptyLoggingContext :: LoggingContext +emptyLoggingContext = LoggingContext [] Nothing Nothing Nothing + +-- | Formerly known as verbosity +data DetailLevel = + DMinimal + | DNormal + | DDetailed + | DMaximum + deriving (Show, Eq, Ord, Bounded, Enum, Generic) + +instance AE.ToJSON DetailLevel where + toEncoding = AE.genericToEncoding AE.defaultOptions +instance AE.FromJSON DetailLevel + +-- | Privacy of a message. Default is Public +data Privacy = + Confidential -- ^ confidential information - handle with care + | Public -- ^ can be public. + deriving (Show, Eq, Ord, Bounded, Enum) + +-- | Severity of a message +data SeverityS + = Debug -- ^ Debug messages + | Info -- ^ Information + | Notice -- ^ Normal runtime Conditions + | Warning -- ^ General Warnings + | Error -- ^ General Errors + | Critical -- ^ Severe situations + | Alert -- ^ Take immediate action + | Emergency -- ^ System is unusable + deriving (Show, Eq, Ord, Bounded, Enum) + +-- | Severity for a filter +data SeverityF + = DebugF -- ^ Debug messages + | InfoF -- ^ Information + | NoticeF -- ^ Normal runtime Conditions + | WarningF -- ^ General Warnings + | ErrorF -- ^ General Errors + | CriticalF -- ^ Severe situations + | AlertF -- ^ Take immediate action + | EmergencyF -- ^ System is unusable + | SilenceF -- ^ Don't show anything + deriving (Show, Eq, Ord, Bounded, Enum, Generic) + +instance AE.ToJSON SeverityF where + toEncoding = AE.genericToEncoding AE.defaultOptions +instance AE.FromJSON SeverityF + +-- | Used as interface object for ForwarderTracer +data TraceObject = TraceObject { + toHuman :: Maybe Text + , toMachine :: Maybe Text + , toNamespace :: Namespace + , toSeverity :: SeverityS + , toDetails :: DetailLevel + , toTimestamp :: UTCTime + , toHostname :: HostName + , toThreadId :: Text +} deriving (Eq, Show) + +---------------------------------------------------------------- +-- Configuration + +-- | +data FormattedMessage = + FormattedHuman Bool Text + -- ^ The bool specifies if the formatting includes colours + | FormattedMachine Text + | FormattedMetrics [Metric] + | FormattedForwarder TraceObject + deriving (Eq, Show) + +-- | +data BackendConfig = + Forwarder + | Stdout FormatLogging + | EKGBackend + deriving (Eq, Ord, Show, Generic) + +instance AE.ToJSON BackendConfig where + toJSON Forwarder = AE.String "Forwarder" + toJSON EKGBackend = AE.String "EKGBackend" + toJSON (Stdout f) = AE.String $ "Stdout " <> (pack . show) f + +instance AE.FromJSON BackendConfig where + parseJSON (AE.String "Forwarder") = pure Forwarder + parseJSON (AE.String "EKGBackend") = pure EKGBackend + parseJSON (AE.String "Stdout HumanFormatColoured") + = pure $ Stdout HumanFormatColoured + parseJSON (AE.String "Stdout HumanFormatUncoloured") + = pure $ Stdout HumanFormatUncoloured + parseJSON (AE.String "Stdout MachineFormat") = pure $ Stdout MachineFormat + parseJSON other = error (show other) + +data FormatLogging = + HumanFormatColoured + | HumanFormatUncoloured + | MachineFormat + deriving (Eq, Ord, Show) + +-- Configuration options for individual namespace elements +data ConfigOption = + -- | Severity level for a filter (default is WarningF) + CoSeverity SeverityF + -- | Detail level (default is DNormal) + | CoDetail DetailLevel + -- | To which backend to pass + -- Default is [EKGBackend, Forwarder, Stdout HumanFormatColoured] + | CoBackend [BackendConfig] + -- | Construct a limiter with name (Text) and limiting to the Double, + -- which represents frequency in number of messages per second + | CoLimiter Text Double + deriving (Eq, Ord, Show) + +newtype RemoteAddr + = LocalSocket FilePath + deriving (Eq, Ord, Show) + +instance AE.FromJSON RemoteAddr where + parseJSON = AE.withObject "RemoteAddr" $ \o -> LocalSocket <$> o AE..: "filePath" + +data TraceConfig = TraceConfig { + -- | Options specific to a certain namespace + tcOptions :: Map.Map Namespace [ConfigOption] + , tcForwarder :: RemoteAddr + , tcForwarderQueueSize :: Int +} + deriving (Eq, Ord, Show) + +emptyTraceConfig :: TraceConfig +emptyTraceConfig = TraceConfig { + tcOptions = Map.empty + , tcForwarder = LocalSocket "forwarder.log" + , tcForwarderQueueSize = 1500 + } + +--------------------------------------------------------------------------- +-- Control and Documentation + +-- | 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 +-- run Reset followed by Config followed by Optimize +data TraceControl where + Reset :: TraceControl + Config :: TraceConfig -> TraceControl + Optimize :: TraceControl + Document :: Int -> Text -> [(Namespace, Text)] -> DocCollector -> TraceControl + +newtype DocCollector = DocCollector (IORef (Map Int LogDoc)) + +data LogDoc = LogDoc { + ldDoc :: Text + , ldMetricsDoc :: Map Namespace Text + , ldNamespace :: [Namespace] + , ldSeverity :: [SeverityS] + , ldPrivacy :: [Privacy] + , ldDetails :: [DetailLevel] + , ldBackends :: [(BackendConfig, FormattedMessage)] + , ldFiltered :: [SeverityF] + , ldLimiter :: [(Text, Double)] +} deriving(Eq, Show) + +emptyLogDoc :: Text -> [(Namespace, Text)] -> LogDoc +emptyLogDoc d m = LogDoc d (Map.fromList m) [] [] [] [] [] [] [] + +-- | Type for a Fold +newtype Folding a b = Folding b + +unfold :: Folding a b -> b +unfold (Folding b) = b + +data PreFormatted a = PreFormatted { + pfMessage :: a + , pfForHuman :: Maybe Text + , pfForMachine :: Maybe AE.Object + } + +instance LogFormatting a => LogFormatting (PreFormatted a) where + forMachine dtal PreFormatted {..} = case pfForMachine of + Nothing -> forMachine dtal pfMessage + Just obj -> obj + forHuman PreFormatted {..} = case pfForHuman of + Nothing -> forHuman pfMessage + Just txt -> txt + asMetrics PreFormatted {..} = asMetrics pfMessage + +--------------------------------------------------------------------------- +-- LogFormatting instances + +instance LogFormatting b => LogFormatting (Folding a b) where + forMachine v (Folding b) = forMachine v b + forHuman (Folding b) = forHuman b + asMetrics (Folding b) = asMetrics b + +instance LogFormatting Double where + forMachine _dtal d = mkObject [ "val" .= AE.String ((pack . show) d)] + forHuman d = (pack . show) d + asMetrics d = [DoubleM [] d] + +instance LogFormatting Int where + forMachine _dtal i = mkObject [ "val" .= AE.String ((pack . show) i)] + forHuman i = (pack . show) i + asMetrics i = [IntM [] (fromIntegral i)] + +instance LogFormatting Integer where + forMachine _dtal i = mkObject [ "val" .= AE.String ((pack . show) i)] + forHuman i = (pack . show) i + asMetrics i = [IntM [] i] diff --git a/trace-dispatcher/src/Control/Tracer.hs b/trace-dispatcher/src/Control/Tracer.hs new file mode 100644 index 00000000000..529c0aaf925 --- /dev/null +++ b/trace-dispatcher/src/Control/Tracer.hs @@ -0,0 +1,240 @@ +{-| +Module : Control.Tracer +Description : A simple interface for logging, tracing, and monitoring +Copyright : (c) Alexander Vieth, 2019 +Maintainer : aovieth@gmail.com +License : Apache-2.0 + +=== General usage + +'Tracer' is a contravariant functor intended to express the pattern in which +values of its parameter type are used to produce effects which are prescribed +by the caller, as in tracing, logging, code instrumentation, etc. + +Programs should be written to use as specific a tracer as possible, i.e. to +take as a parameter a @Tracer m domainSpecificType@. To combine these programs +into an executable which does meaningful tracing, an implementation of that +tracing should be used to make a @Tracer probablyIO implementationTracingType@, +which is 'contramap'ped to fit @Tracer m domainSpecificType@ wherever it is +needed, for the various @domainSpecificType@s that appear throughout the +program. + +=== An example + +This short example shows how a tracer can be deployed, highlighting the use of +'contramap' to fit a general tracer which writes text to a file, where a +specific tracer which takes domain-specific events is expected. + +> -- Writes text to some log file. +> traceToLogFile :: FilePath -> Tracer IO Text +> +> -- Domain-specific event type. +> data Event = EventA | EventB Int +> +> -- The log-file format for an Event. +> eventToText :: Event -> Text +> +> -- Some action that can use any tracer on Event, in any monad. +> actionWithTrace :: Monad m => Tracer m Event -> m () +> actionWithTrace tracer = do +> traceWith tracer EventA +> traceWith tracer (EventB 42) +> +> -- Set up a log file tracer, then use it where the Event tracer is expected. +> main :: IO () +> main = do +> textTacer <- traceToLogFile "log.txt" +> let eventTracer :: Tracer IO Event +> eventTracer = contramap eventToText tracer +> actionWithTrace eventTracer +-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Control.Tracer + ( Tracer (..) + , traceWith + , arrow + , use + , Arrow.squelch + , Arrow.emit + , Arrow.effect + -- * Simple tracers + , nullTracer + , stdoutTracer + , debugTracer + -- * Transforming tracers + , natTracer + , Arrow.nat + , traceMaybe + , squelchUnless + -- * Re-export of Contravariant + , Contravariant(..) + ) where + +import Control.Arrow ((|||), (&&&), arr, runKleisli) +import Control.Category ((>>>)) +import Data.Functor.Contravariant (Contravariant (..)) +import Debug.Trace (traceM) + +import qualified Control.Tracer.Arrow as Arrow + +-- | This type describes some effect in @m@ which depends upon some value of +-- type @a@, for which the /output value/ is not of interest (only the effects). +-- +-- The motivating use case is to describe tracing, logging, monitoring, and +-- similar features, in which the programmer wishes to provide some values to +-- some /other/ program which will do some real world side effect, such as +-- writing to a log file or bumping a counter in some monitoring system. +-- +-- The actual implementation of such a program will probably work on rather +-- large, domain-agnostic types like @Text@, @ByteString@, JSON values for +-- structured logs, etc. +-- +-- But the call sites which ultimately /invoke/ these implementations will deal +-- with smaller, domain-specific types that concisely describe events, metrics, +-- debug information, etc. +-- +-- This difference is reconciled by the 'Contravariant' instance for 'Tracer'. +-- 'Data.Functor.Contravariant.contramap' is used to change the input type of +-- a tracer. This allows for a more general tracer to be used where a more +-- specific one is expected. +-- +-- Intuitively: if you can map your domain-specific type @Event@ to a @Text@ +-- representation, then any @Tracer m Text@ can stand in where a +-- @Tracer m Event@ is required. +-- +-- > eventToText :: Event -> Text +-- > +-- > traceTextToLogFile :: Tracer m Text +-- > +-- > traceEventToLogFile :: Tracer m Event +-- > traceEventToLogFile = contramap eventToText traceTextToLogFile +-- +-- Effectful tracers that actually do interesting stuff can be defined +-- using 'emit', and composed via 'contramap'. +-- +-- The 'nullTracer' can be used as a stand-in for any tracer, doing no +-- side-effects and producing no interesting value. +-- +-- To deal with branching, the arrow interface on the underlying +-- 'Control.Tracer.Arrow.Tracer' should be used. Arrow notation can be helpful +-- here. +-- +-- For example, a common pattern is to trace only some variants of a sum type. +-- +-- > data Event = This Int | That Bool +-- > +-- > traceOnlyThat :: Tracer m Int -> Tracer m Bool +-- > traceOnlyThat tr = Tracer $ proc event -> do +-- > case event of +-- > This i -> use tr -< i +-- > That _ -> squelch -< () +-- +-- The key point of using the arrow representation we have here is that this +-- tracer will not necessarily need to force @event@: if the input tracer @tr@ +-- does not force its value, then @event@ will not be forced. To elaborate, +-- suppose @tr@ is @nullTracer@. Then this expression becomes +-- +-- > classify (This i) = Left i +-- > classify (That _) = Right () +-- > +-- > traceOnlyThat tr +-- > = Tracer $ Pure classify >>> (squelch ||| squelch) >>> Pure (either id id) +-- > = Tracer $ Pure classify >>> Pure (either (const (Left ())) (const (Right ()))) >>> Pure (either id id) +-- > = Tracer $ Pure (classify >>> either (const (Left ())) (const (Right ())) >>> either id id) +-- +-- So that when this tracer is run by 'traceWith' we get +-- +-- > traceWith (traceOnlyThat tr) x +-- > = traceWith (Pure _) +-- > = pure () +-- +-- It is _essential_ that the computation of the tracing effects cannot itself +-- have side-effects, as this would ruin the ability to short-circuit when +-- it is known that no tracing will be done: the side-effects of a branch +-- could change the outcome of another branch. This would fly in the face of +-- a crucial design goal: you can leave your tracer calls in the program so +-- they do not bitrot, but can also make them zero runtime cost by substituting +-- 'nullTracer' appropriately. +newtype Tracer m a = Tracer { runTracer :: Arrow.TracerA m a () } + +instance Monad m => Contravariant (Tracer m) where + contramap f tracer = Tracer (arr f >>> use tracer) + +-- | @tr1 <> tr2@ will run @tr1@ and then @tr2@ with the same input. +instance Monad m => Semigroup (Tracer m s) where + Tracer a1 <> Tracer a2 = Tracer (a1 &&& a2 >>> arr discard) + where + discard :: ((), ()) -> () + discard = const () + +instance Monad m => Monoid (Tracer m s) where + mappend = (<>) + mempty = nullTracer + +{-# INLINE traceWith #-} +-- | Run a tracer with a given input. +traceWith :: Monad m => Tracer m a -> a -> m () +traceWith (Tracer tr) = runKleisli (Arrow.runTracerA tr) + +-- | Inverse of 'use'. +arrow :: Arrow.TracerA m a () -> Tracer m a +arrow = Tracer + +-- | Inverse of 'arrow'. Useful when writing arrow tracers which use a +-- contravariant tracer (the newtype in this module). +use :: Tracer m a -> Arrow.TracerA m a () +use = runTracer + +-- | A tracer which does nothing. +nullTracer :: Monad m => Tracer m a +nullTracer = Tracer Arrow.squelch + +-- | Create a simple contravariant tracer which runs a given side-effect. +emit :: Applicative m => (a -> m ()) -> Tracer m a +emit f = Tracer (Arrow.emit f) + +-- | Run a tracer only for the Just variant of a Maybe. If it's Nothing, the +-- 'nullTracer' is used (no output). +-- +-- The arrow representation allows for proper laziness: if the tracer parameter +-- does not produce any tracing effects, then the predicate won't even be +-- evaluated. Contrast with the simple contravariant representation as +-- @a -> m ()@, in which the predicate _must_ be forced no matter what, +-- because it's impossible to know a priori whether that function will not +-- produce any tracing effects. +-- +-- It's written out explicitly for demonstration. Could also use arrow +-- notation: +-- +-- > traceMaybe p tr = Tracer $ proc a -> do +-- > case k a of +-- > Just b -> use tr -< b +-- > Nothing -> Arrow.squelch -< () +-- +traceMaybe :: Monad m => (a -> Maybe b) -> Tracer m b -> Tracer m a +traceMaybe k tr = Tracer $ classify >>> (Arrow.squelch ||| use tr) + where + classify = arr (maybe (Left ()) Right . k) + +-- | Uses 'traceMaybe' to give a tracer which emits only if a predicate is true. +squelchUnless :: Monad m => (a -> Bool) -> Tracer m a -> Tracer m a +squelchUnless p = traceMaybe (\a -> if p a then Just a else Nothing) + +-- | Use a natural transformation to change the @m@ type. This is useful, for +-- instance, to use concrete IO tracers in monad transformer stacks that have +-- IO as their base. +natTracer :: forall m n s . (forall x . m x -> n x) -> Tracer m s -> Tracer n s +natTracer h (Tracer tr) = Tracer (Arrow.nat h tr) + +-- | Trace strings to stdout. Output could be jumbled when this is used from +-- multiple threads. Consider 'debugTracer' instead. +stdoutTracer :: Tracer IO String +stdoutTracer = emit putStrLn + +-- | Trace strings using 'Debug.Trace.traceM'. This will use stderr. See +-- documentation in "Debug.Trace" for more details. +debugTracer :: Applicative m => Tracer m String +debugTracer = emit traceM diff --git a/trace-dispatcher/src/Control/Tracer/Arrow.hs b/trace-dispatcher/src/Control/Tracer/Arrow.hs new file mode 100644 index 00000000000..fe6668af650 --- /dev/null +++ b/trace-dispatcher/src/Control/Tracer/Arrow.hs @@ -0,0 +1,90 @@ +{-| +Module : Control.TracerA.Arrow +Copyright : (c) Alexander Vieth, 2019 +Licence : Apache-2.0 +Maintainer : aovieth@gmail.com +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +module Control.Tracer.Arrow + ( TracerA (..) + , runTracerA + , compute + , emit + , effect + , squelch + , nat + ) where + +import Prelude hiding ((.), id) +import Control.Arrow +import Control.Category + +-- | Formal representation of a tracer arrow as a Kleisli arrow over some +-- monad, but tagged so that we know whether it has any effects which will emit +-- a trace. +data TracerA m a b where + -- | An emitting part, followed by a non-emitting part. + -- The non-emitting part is there so that later emitting parts can be + -- tacked-on later. + Emitting :: Kleisli m a x -> Kleisli m x b -> TracerA m a b + -- | No emitting. There may be side-effects, but they are assumed to be + -- benign and will be discarded by 'runTracerA'. + Squelching :: Kleisli m a b -> TracerA m a b + +-- | The resulting Kleisli arrow includes all of the effects required to do +-- the emitting part. +runTracerA :: Monad m => TracerA m a () -> Kleisli m a () +runTracerA (Emitting emits _noEmits) = emits >>> arr (const ()) +runTracerA (Squelching _ ) = arr (const ()) + +-- | Ignore the input and do not emit. The name is intended to lead to clear +-- and suggestive arrow expressions. +squelch :: Applicative m => TracerA m a () +squelch = compute (const ()) + +-- | Do an emitting effect. Contrast with 'effect' which does not make the +-- tracer an emitting tracer. +emit :: Applicative m => (a -> m ()) -> TracerA m a () +emit f = Emitting (Kleisli f) (Kleisli (const (pure ()))) + +-- | Do a non-emitting effect. This effect will only be run if some part of +-- the tracer downstream emits (see 'emit'). +effect :: (a -> m b) -> TracerA m a b +effect = Squelching . Kleisli + +-- | Pure computation in a tracer: no side effects or emits. +compute :: Applicative m => (a -> b) -> TracerA m a b +compute f = effect (pure . f) + +instance Monad m => Category (TracerA m) where + id = compute id + Squelching l . Squelching r = Squelching (l . r) + -- Crucial: the squelching parts stay together. Could also have written + -- = Emitting (rp . re) l + -- but that would miss opportunities to skip doing work. + Squelching l . Emitting re rp = Emitting re (l . rp) + -- Contrast with the above clause: here the emitting part comes _after_ the + -- squelching part, so the squelching part becomes part of the emitting part. + Emitting le lp . Squelching r = Emitting (le . r) lp + Emitting le lp . Emitting re rp = Emitting (le . rp . re) lp + +instance Monad m => Arrow (TracerA m) where + arr = compute + Squelching l *** Squelching r = Squelching (l *** r ) + Squelching l *** Emitting re rp = Emitting (second re) (l *** rp) + Emitting le lp *** Squelching r = Emitting (first le) (lp *** r ) + Emitting le lp *** Emitting re rp = Emitting (le *** re) (lp *** rp) + +instance Monad m => ArrowChoice (TracerA m) where + Squelching l +++ Squelching r = Squelching (l +++ r) + Squelching l +++ Emitting re rp = Emitting (id +++ re) (l +++ rp) + Emitting le lp +++ Squelching r = Emitting (le +++ id) (lp +++ r ) + Emitting le lp +++ Emitting re rp = Emitting (le +++ re) (lp +++ rp) + +-- | Use a natural transformation to change the underlying monad. +nat :: (forall x . m x -> n x) -> TracerA m a b -> TracerA n a b +nat h (Squelching (Kleisli k)) = Squelching (Kleisli (h . k)) +nat h (Emitting (Kleisli k) (Kleisli l)) = Emitting (Kleisli (h . k)) (Kleisli (h . l)) diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Config.hs b/trace-dispatcher/test/Cardano/Logging/Test/Config.hs new file mode 100644 index 00000000000..67bd46feb73 --- /dev/null +++ b/trace-dispatcher/test/Cardano/Logging/Test/Config.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Logging.Test.Config ( + ) where + +import Data.Map (fromList) +import Test.QuickCheck + +import Cardano.Logging + + +-- | different configurations for testing +config1 :: TraceConfig +config1 = emptyTraceConfig { + tcOptions = fromList + [([] :: Namespace, + [ CoSeverity DebugF + , CoDetail DNormal + , CoBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] + ]) + ] + } + +config2 :: TraceConfig +config2 = emptyTraceConfig { + tcOptions = fromList + [ ([] :: Namespace, + [ CoSeverity DebugF + , CoDetail DNormal + , CoBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] + ]) + , (["Node", "Test", "Message1"], + [ CoSeverity InfoF + , CoDetail DNormal + , CoBackend [Stdout HumanFormatColoured, EKGBackend] + ]) + , (["Node", "Test", "Message2"], + [ CoSeverity ErrorF + , CoDetail DMinimal + , CoBackend [Forwarder, EKGBackend] + ]) + ] + } + +instance Arbitrary TraceConfig where + arbitrary = elements [config1, config2] diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Messages.hs b/trace-dispatcher/test/Cardano/Logging/Test/Messages.hs new file mode 100644 index 00000000000..87af367c4e3 --- /dev/null +++ b/trace-dispatcher/test/Cardano/Logging/Test/Messages.hs @@ -0,0 +1,54 @@ +module Cardano.Logging.Test.Messages ( + namesForMessage + , severityForMessage + , privacyForMessage + , docMessage + , getMessageID + , setMessageID + ) where + +import Data.Text + +import Cardano.Logging +import Cardano.Logging.Test.Types + +getMessageID :: Message -> MessageID +getMessageID (Message1 mid _) = mid +getMessageID (Message2 mid _) = mid +getMessageID (Message3 mid _) = mid + +setMessageID :: Message -> MessageID -> Message +setMessageID (Message1 _ v) mid = Message1 mid v +setMessageID (Message2 _ v) mid = Message2 mid v +setMessageID (Message3 _ v) mid = Message3 mid v + +namesForMessage :: Message -> [Text] +namesForMessage Message1 {} = ["Message1"] +namesForMessage Message2 {} = ["Message2"] +namesForMessage Message3 {} = ["Message3"] + +severityForMessage :: Message -> SeverityS +severityForMessage Message1 {} = Debug +severityForMessage Message2 {} = Info +severityForMessage Message3 {} = Error + +privacyForMessage :: Message -> Privacy +privacyForMessage Message1 {} = Public +privacyForMessage Message2 {} = Confidential +privacyForMessage Message3 {} = Public + +docMessage :: Documented Message +docMessage = Documented [ + DocMsg + (Message1 1 1) + [] + "The first message." + , DocMsg + (Message2 1 "") + [] + "The second message." + , DocMsg + (Message3 1 1.0) + [(["Metrics1"], "A number")] + "The third message." + ] diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs b/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs new file mode 100644 index 00000000000..8a82b3fb42c --- /dev/null +++ b/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Logging.Test.Oracles ( + oracleFiltering + , occurences + ) where + +import qualified Data.Text as T +import Test.QuickCheck +import Text.Read (readMaybe) + +import Cardano.Logging +import Cardano.Logging.Test.Messages +import Cardano.Logging.Test.Types + +import Debug.Trace + + +-- | Checks for every message that it appears or does not appear at the right +-- backend. Tests filtering and routing to backends +oracleFiltering :: TraceConfig -> ScriptRes -> Property +oracleFiltering conf ScriptRes {..} = + let Script msgs = srScript + in property $ all oracleMessage msgs + where + oracleMessage :: ScriptedMessage -> Bool + oracleMessage (ScriptedMessage _t msg) = + let filterSeverity = getSeverity conf ("Node" : "Test" : namesForMessage msg) + backends = getBackends conf ("Node" : "Test" : namesForMessage msg) + inStdout = hasStdoutBackend backends + && fromEnum (severityForMessage msg) >= fromEnum filterSeverity + isCorrectStdout = includedExactlyOnce msg srStdoutRes == inStdout + inForwarder = elem Forwarder backends + && fromEnum (severityForMessage msg) >= fromEnum filterSeverity + && privacyForMessage msg == Public + isCorrectForwarder = includedExactlyOnce msg srForwardRes == inForwarder + inEKG = elem EKGBackend backends + && fromEnum (severityForMessage msg) >= fromEnum filterSeverity + && not (null (asMetrics msg)) + isCorrectEKG = includedExactlyOnce msg srEkgRes == inEKG + res = isCorrectStdout && isCorrectForwarder && isCorrectEKG + in case traceMessage isCorrectStdout isCorrectForwarder isCorrectEKG msg of + Nothing -> res + Just str -> trace str res + traceMessage :: Bool -> Bool -> Bool -> Message -> Maybe String + traceMessage isCorrectStdout isCorrectForwarder isCorrectEKG msg + | not isCorrectStdout + = Just + ("stdoutTracer wrong filtering or routing for " + <> show msg <> " config " <> show conf) + | not isCorrectForwarder + = Just + ("forwardTracer wrong filtering or routing for " + <> show msg <> " config " <> show conf) + | not isCorrectEKG + = Just + ("ekgTracer wrong filtering or routing for " + <> show msg <> " config " <> show conf) + | otherwise = Nothing + + +-- | Is the stdout backend included in this configuration +hasStdoutBackend :: [BackendConfig] -> Bool +hasStdoutBackend [] = False +hasStdoutBackend (Stdout _ : _) = True +hasStdoutBackend (_ : rest) = hasStdoutBackend rest + +-- | Is this message in some form included in the formatted messages exactly once +includedExactlyOnce :: Message -> [FormattedMessage] -> Bool +includedExactlyOnce msg list = + let msgID = getMessageID msg + in case occurences msgID list of + 1 -> True + 0 -> False + _ -> error $ "Multiple occurences of message " <> show msgID + +-- | How often does the message with this id appears in the list of +-- formatted messsages? +occurences :: MessageID -> [FormattedMessage] -> Int +occurences _mid [] = 0 +occurences mid (fmsg : rest) = if isMessageWithId mid fmsg + then 1 + occurences mid rest + else occurences mid rest + +-- | Returns true if the given message has this id, otherwise fals +isMessageWithId :: MessageID -> FormattedMessage -> Bool +isMessageWithId mid (FormattedMetrics [IntM _ idm]) + = fromIntegral idm == mid +isMessageWithId _ (FormattedMetrics []) = False +isMessageWithId mid (FormattedHuman _ txt) = idInText mid txt +isMessageWithId mid (FormattedMachine txt) = idInText mid txt +isMessageWithId mid (FormattedForwarder to) = + case toHuman to of + Just txt -> idInText mid txt + Nothing -> case toMachine to of + Just txt -> idInText mid txt + Nothing -> error "No text found in trace object" + +-- | Is this message id part of the text? +idInText :: MessageID -> T.Text -> Bool +idInText mid txt = + case extractId txt of + Nothing -> False + Just i -> i == mid + +-- | Extract a messageID from a text. It is always fumnd in the form '' +extractId :: T.Text -> Maybe Int +extractId txt = + let ntxt = T.takeWhile (/= '>') + (T.drop 1 + (T.dropWhile (/= '<') txt)) + in readMaybe (T.unpack ntxt) diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Script.hs b/trace-dispatcher/test/Cardano/Logging/Test/Script.hs new file mode 100644 index 00000000000..86c3fa88447 --- /dev/null +++ b/trace-dispatcher/test/Cardano/Logging/Test/Script.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +module Cardano.Logging.Test.Script + ( + runScriptSimple + , runScriptMultithreaded + ) where + +import Control.Concurrent (ThreadId, forkFinally, threadDelay) +import Control.Concurrent.MVar +import Control.Exception.Base (SomeException, throw) +import Control.Monad (when) +import Data.IORef (newIORef, readIORef) +import Data.List (sort) +import Data.Maybe (mapMaybe) +import Test.QuickCheck + +import Cardano.Logging +import Cardano.Logging.Test.Config () +import Cardano.Logging.Test.Messages +import Cardano.Logging.Test.Tracer +import Cardano.Logging.Test.Types + +import Debug.Trace + + +-- | Run a script in a single thread and uses the oracle to test for correctness +-- The duration of the test is given by time in seconds +runScriptSimple :: + Double + -> (TraceConfig -> ScriptRes -> Property) + -> Property +runScriptSimple time oracle = do + let generator :: Gen (Script, TraceConfig) = arbitrary + forAll generator (\ (script,conf) -> ioProperty $ do + scriptResult <- playScript time conf 0 script + -- trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) + -- <> " forwardTrRes " <> show (srForwardRes scriptResult) + -- <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ + pure $ oracle conf scriptResult) + + +-- | Run three scripts in three threads in parallel +-- and use the oracle to test for correctness. +-- The duration of the test is given by time in seconds +runScriptMultithreaded :: + Double + -> (TraceConfig -> ScriptRes -> Property) + -> Property +runScriptMultithreaded time oracle = do + let generator :: Gen (Script, Script, Script, TraceConfig) = arbitrary + forAll generator (\ (script1, script2, script3, conf) -> ioProperty $ do + children :: MVar [MVar (Either SomeException ScriptRes)] <- newMVar [] + _ <- forkChild children (playScript time conf 0 script1) + let start1 = scriptLength script1 + _ <- forkChild children (playScript time conf start1 script2) + let start2 = start1 + scriptLength script2 + _ <- forkChild children (playScript time conf start2 script3) + res <- waitForChildren children [] + let res' = mapMaybe + (\case + Right rR -> Just rR + Left _ -> Nothing) res + let resErr = mapMaybe + (\case + Right _ -> Nothing + Left err -> Just err) res + if not (null resErr) + then throw (head resErr) + else do + let scriptResult = mergeResults res' + trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) + <> " forwardTrRes " <> show (srForwardRes scriptResult) + <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ + pure $ oracle conf scriptResult) + where + forkChild :: MVar [MVar (Either SomeException ScriptRes)] -> IO ScriptRes -> IO ThreadId + forkChild children io = do + mvar <- newEmptyMVar + childs <- takeMVar children + putMVar children (mvar:childs) + forkFinally io (putMVar mvar) + waitForChildren :: MVar [MVar (Either SomeException ScriptRes)] + -> [Either SomeException ScriptRes] + -> IO [Either SomeException ScriptRes] + waitForChildren children accum = do + cs <- takeMVar children + case cs of + [] -> pure accum + m:ms -> do + putMVar children ms + res <- takeMVar m + waitForChildren children (res : accum) + + +-- | Plays a script in a single thread +playScript :: Double -> TraceConfig -> Int -> Script -> IO ScriptRes +playScript time config firstId (Script msgs) = do + stdoutTrRef <- newIORef [] + stdoutTracer' <- testTracer stdoutTrRef + forwardTrRef <- newIORef [] + forwardTracer' <- testTracer forwardTrRef + ekgTrRef <- newIORef [] + ekgTracer' <- testTracer ekgTrRef + tr <- mkCardanoTracer + stdoutTracer' + forwardTracer' + (Just ekgTracer') + "Test" + namesForMessage + severityForMessage + privacyForMessage + + let sortedMsgs = sort msgs + let (msgsWithIds,_) = withMessageIds firstId sortedMsgs + let timedMessages = map (withTimeFactor time) msgsWithIds + + configureTracers config docMessage [tr] + -- trace ("playScript " <> show timedMessages) $ + playIt (Script timedMessages) tr 0.0 + r1 <- readIORef stdoutTrRef + r2 <- readIORef forwardTrRef + r3 <- readIORef ekgTrRef + pure (ScriptRes + (Script timedMessages) + (reverse r1) + (reverse r2) + (reverse r3)) + +-- | Play the current script in one thread +-- The time is in milliseconds +playIt :: Script -> Trace IO Message -> Double -> IO () +playIt (Script []) _tr _d = pure () +playIt (Script (ScriptedMessage d1 m1 : rest)) tr d = do + when (d < d1) $ threadDelay (round ((d1 - d) * 1000000)) + -- this is in microseconds + traceWith tr m1 + playIt (Script rest) tr d1 + +-- | Adds a message id to every message. +-- MessageId gives the id to start with. +-- Returns a tuple with the messages with ids and +-- the successor of the last used messageId +withMessageIds :: MessageID -> [ScriptedMessage] -> ([ScriptedMessage], MessageID) +withMessageIds mid sMsgs = go mid sMsgs [] + where + go mid' [] acc = (reverse acc, mid') + go mid' (ScriptedMessage time msg : tl) acc = + go (mid' + 1) tl (ScriptedMessage time (setMessageID msg mid') : acc) + +withTimeFactor :: Double -> ScriptedMessage -> ScriptedMessage +withTimeFactor factor (ScriptedMessage time msg) = + ScriptedMessage (time * factor) msg + +mergeResults :: [ScriptRes] -> ScriptRes +mergeResults results = + let script = Script $ + concatMap + (\r -> case srScript r of + Script scriptedList -> scriptedList) results + stdOutRes = concatMap srStdoutRes results + forwardRes = concatMap srForwardRes results + ekgRes = concatMap srEkgRes results + in ScriptRes script stdOutRes forwardRes ekgRes diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs b/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs new file mode 100644 index 00000000000..9f7947add1f --- /dev/null +++ b/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Logging.Test.Tracer ( + testTracer + ) where + +import Data.IORef +import Control.Monad.IO.Class + +import Cardano.Logging + +testTracer :: MonadIO m + => IORef [FormattedMessage] + -> m (Trace m FormattedMessage) +testTracer ioRef = liftIO $ do + pure $ Trace $ arrow $ emit output + where + output (LoggingContext{}, Nothing, msg) = liftIO $ do + modifyIORef ioRef (msg :) + output (LoggingContext{}, _, _) = pure () diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs new file mode 100644 index 00000000000..88d1f0f59c5 --- /dev/null +++ b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs @@ -0,0 +1,92 @@ +module Cardano.Logging.Test.Types ( + MessageID + , Message (..) + , ScriptedMessage (..) + , Script (..) + , ScriptRes (..) + , scriptLength + ) where + +import Data.Aeson (Value (..), (.=)) +import Data.Text hiding (length) +import Test.QuickCheck + +import Cardano.Logging + +type MessageID = Int + +data Message = + Message1 MessageID Int + | Message2 MessageID Text + | Message3 MessageID Double + deriving (Eq, Ord, Show) + + +showT :: Show a => a -> Text +showT = pack . show + +instance LogFormatting Message where + forMachine _dtal (Message1 mid i) = + mkObject [ "kind" .= String "Message1" + , "mid" .= ("<" <> showT mid <> ">") + , "workload" .= String (showT i) + ] + forMachine DMinimal (Message2 mid _s) = + mkObject [ "mid" .= ("<" <> showT mid <> ">") + , "kind" .= String "Message2" + ] + forMachine _dtal (Message2 mid s) = + mkObject [ "kind" .= String "Message2" + , "mid" .= String ("<" <> showT mid <> ">") + , "workload" .= String s + ] + forMachine _dtal (Message3 mid d) = + mkObject [ "kind" .= String "Message3" + , "mid" .= String (showT mid) + , "workload" .= String (showT d) + ] + forHuman (Message1 mid i) = + "Message1 <" <> showT mid <> "> " <> showT i + forHuman (Message2 mid s) = + "Message2 <" <> showT mid <> "> " <> s + forHuman (Message3 mid d) = + "Message3 <" <> showT mid <> "> " <> showT d + asMetrics (Message1 mid _i) = + [IntM ["Metrics1"] (fromIntegral mid)] + asMetrics _ = [] + +instance Arbitrary Message where + arbitrary = oneof + [ Message1 0 <$> arbitrary, + Message2 0 <$> elements ["Hallo", "Goodbye", "Whatelse"], + Message3 0 <$> arbitrary + ] + + +-- | Adds a time between 0 and 1. +-- 0 is the time of the test start, and 1 the test end +data ScriptedMessage = ScriptedMessage Double Message + deriving (Eq, Show) + +-- Ordered by time +instance Ord ScriptedMessage where + compare (ScriptedMessage d1 _m1) (ScriptedMessage d2 _m2) = compare d1 d2 + +instance Arbitrary ScriptedMessage where + arbitrary = ScriptedMessage <$> choose (0.0, 1.0) <*> arbitrary + +newtype Script = Script [ScriptedMessage] + deriving (Eq, Show) + +scriptLength :: Script -> Int +scriptLength (Script m) = length m + +instance Arbitrary Script where + arbitrary = Script <$> listOf arbitrary + +data ScriptRes = ScriptRes { + srScript :: Script + , srStdoutRes :: [FormattedMessage] + , srForwardRes :: [FormattedMessage] + , srEkgRes :: [FormattedMessage] + } diff --git a/trace-dispatcher/test/trace-dispatcher-test.hs b/trace-dispatcher/test/trace-dispatcher-test.hs new file mode 100644 index 00000000000..36af3c9629a --- /dev/null +++ b/trace-dispatcher/test/trace-dispatcher-test.hs @@ -0,0 +1,21 @@ + +{-# OPTIONS_GHC -Wno-unused-imports #-} + +import Test.Tasty +import Test.Tasty.QuickCheck + +import Cardano.Logging +import Cardano.Logging.Test.Oracles +import Cardano.Logging.Test.Script + + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = localOption (QuickCheckTests 10) $ testGroup "trace-dispatcher" + [ testProperty "not-filtered" $ + runScriptSimple 1.0 oracleFiltering + , testProperty "not-filtered multithreaded" $ + runScriptMultithreaded 1.0 oracleFiltering + ] diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal new file mode 100644 index 00000000000..a4ca509e179 --- /dev/null +++ b/trace-dispatcher/trace-dispatcher.cabal @@ -0,0 +1,151 @@ +cabal-version: 2.4 +name: trace-dispatcher +version: 0.1.0.0 + +synopsis: Package for development of simple and efficient tracers + based on the arrow based contra-tracer package +author: Juergen Nicklisch-Franken +maintainer: operations@iohk.io +copyright: 2020 IOHK +extra-source-files: CHANGELOG.md + README.md + doc/trace-dispatcher.md + +library + hs-source-dirs: src + exposed-modules: Cardano.Logging + Cardano.Logging.Types + Cardano.Logging.Trace + Cardano.Logging.Configuration + Cardano.Logging.DocuGenerator + Cardano.Logging.Formatter + Cardano.Logging.FrequencyLimiter + Cardano.Logging.Tracer.EKG + Cardano.Logging.Tracer.Standard + Cardano.Logging.Tracer.Forward + Cardano.Logging.Tracer.Composed + Control.Tracer.Arrow + Control.Tracer + + default-language: Haskell2010 + default-extensions: OverloadedStrings + build-depends: base >=4.12 && <5 + , aeson + , async + , bytestring + , cborg + , containers + , contra-tracer + , ekg + , ekg-core + , ekg-forward + , hostname + , network + , ouroboros-network-framework + , serialise + , stm + , text + , time + , trace-forward + , unagi-chan + , unliftio + , unliftio-core + , unordered-containers + , yaml + + if os(windows) + build-depends: Win32 + else + build-depends: unix + + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wno-incomplete-patterns + + +executable trace-dispatcher-examples + main-is: Main.hs + other-modules: Examples.TestObjects + Examples.Aggregation + Examples.Trivial + Examples.Routing + Examples.EKG + Examples.Configuration + Examples.FrequencyLimiting + Examples.Documentation + hs-source-dirs: examples + default-language: Haskell2010 + default-extensions: OverloadedStrings + build-depends: base >=4.12 && <5 + , aeson + , bytestring + , containers + , ekg + , ekg-core + , hostname + , text + , trace-dispatcher + , time + , unagi-chan + , unliftio + , unliftio-core + , stm + , unordered-containers + , yaml + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wno-incomplete-patterns + +test-suite trace-dispatcher-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: trace-dispatcher-test.hs + other-modules: Cardano.Logging.Test.Types + Cardano.Logging.Test.Oracles + Cardano.Logging.Test.Config + Cardano.Logging.Test.Tracer + Cardano.Logging.Test.Messages + Cardano.Logging.Test.Script + default-language: Haskell2010 + default-extensions: OverloadedStrings + build-depends: base >=4.12 && <5 + , aeson + , bytestring + , containers + , ekg + , ekg-core + , hostname + , text + , trace-dispatcher + , time + , unagi-chan + , unliftio + , unliftio-core + , stm + , unordered-containers + , yaml + , QuickCheck + , tasty + , tasty-quickcheck + + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wno-incomplete-patterns diff --git a/trace-resources/.gitignore b/trace-resources/.gitignore new file mode 100644 index 00000000000..e825f8bed1c --- /dev/null +++ b/trace-resources/.gitignore @@ -0,0 +1,11 @@ +.cabal-sandbox +dist +cabal.sandbox.config +TAGS +.stack-work/ +*.o +*.hi +*.dyn_o +*.dyn_hi +stack.yaml.lock +*.pdf diff --git a/trace-resources/CHANGELOG.md b/trace-resources/CHANGELOG.md new file mode 100644 index 00000000000..9ef8d24bdba --- /dev/null +++ b/trace-resources/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. diff --git a/trace-resources/README.md b/trace-resources/README.md new file mode 100644 index 00000000000..df371933b90 --- /dev/null +++ b/trace-resources/README.md @@ -0,0 +1,3 @@ +trace-resources + +Query resource statistics for various platforms for tracing. diff --git a/trace-resources/src/Cardano/Logging/Resources.hs b/trace-resources/src/Cardano/Logging/Resources.hs new file mode 100644 index 00000000000..89677bb7335 --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} + +module Cardano.Logging.Resources + ( + ResourceStats(..) + , readResourceStats + ) where + + +import Cardano.Logging.Resources.Types +#if defined(linux_HOST_OS) +import qualified Cardano.Logging.Resources.Linux as Platform +#elif defined(mingw32_HOST_OS) +import qualified Cardano.Logging.Resources.Windows as Platform +#elif defined(darwin_HOST_OS) +import qualified Cardano.Logging.Resources.Darwin as Platform +#else +import qualified Cardano.Logging.Resources.Dummy as Platform +#endif + + +readResourceStats :: IO (Maybe ResourceStats) +readResourceStats = Platform.readRessoureStatsInternal diff --git a/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc b/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc new file mode 100644 index 00000000000..4506dfc7109 --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Cardano.Logging.Resources.Darwin + ( readRessoureStatsInternal + ) where + +#include "os-support-darwin.h" + +import Data.Word (Word64) +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import qualified GHC.Stats as GhcStats +import System.Posix.Process (getProcessID) +import System.Posix.Types (ProcessID) +import Cardano.Logging.Resources.Types + +{- type aliases -} +type MACH_VM_SIZE_T = Word64 +data TIME_VALUE_T = TIME_VALUE_T Word64 Word64 + +{- memory information -} + +{- mach/task_info.h +struct time_value { + integer_t seconds; + integer_t microseconds; +}; +struct mach_task_basic_info { + mach_vm_size_t virtual_size; /* virtual memory size (bytes) */ + mach_vm_size_t resident_size; /* resident memory size (bytes) */ + mach_vm_size_t resident_size_max; /* maximum resident memory size (bytes) */ + time_value_t user_time; /* total user run time for + * terminated threads */ + time_value_t system_time; /* total system run time for + * terminated threads */ + policy_t policy; /* default policy for new threads */ + integer_t suspend_count; /* suspend count for task */ +}; -} + +data MachTaskBasicInfo = MachTaskBasicInfo + { _virtual_size :: !MACH_VM_SIZE_T + , _resident_size :: !MACH_VM_SIZE_T + , _resident_size_max :: !MACH_VM_SIZE_T + , _user_time :: !TIME_VALUE_T + , _system_time :: !TIME_VALUE_T + , _policy :: !Word64 + , _suspend_count :: !Word64 + } + +instance Storable TIME_VALUE_T where + alignment _ = #const offsetof(struct {char x__; struct time_value (y__); }, y__) + sizeOf _ = #size struct time_value + peek ptr = TIME_VALUE_T + <$> (#peek struct time_value, seconds) ptr + <*> (#peek struct time_value, microseconds) ptr + poke _ _ = pure () + +instance Storable MachTaskBasicInfo where + alignment _ = #const offsetof(struct {char x__; struct mach_task_basic_info (y__); }, y__) + sizeOf _ = #size struct mach_task_basic_info + peek ptr = MachTaskBasicInfo + <$> (#peek struct mach_task_basic_info, virtual_size) ptr + <*> (#peek struct mach_task_basic_info, resident_size) ptr + <*> (#peek struct mach_task_basic_info, resident_size_max) ptr + <*> (#peek struct mach_task_basic_info, user_time) ptr + <*> (#peek struct mach_task_basic_info, system_time) ptr + <*> (#peek struct mach_task_basic_info, policy) ptr + <*> (#peek struct mach_task_basic_info, suspend_count) ptr + poke _ _ = pure () + +foreign import ccall unsafe c_get_process_memory_info :: Ptr MachTaskBasicInfo -> CInt -> IO CInt + + +getMemoryInfo :: ProcessID -> IO MachTaskBasicInfo +getMemoryInfo pid = + allocaBytes 128 $ \ptr -> do + res <- c_get_process_memory_info ptr (fromIntegral pid) + if res <= 0 + then do + putStrLn $ "c_get_process_memory_info: failure returned: " ++ (show res) + return $ MachTaskBasicInfo 0 0 0 (TIME_VALUE_T 0 0) (TIME_VALUE_T 0 0) 0 0 + else + peek ptr + +readRessoureStatsInternal :: IO (Maybe ResourceStats) +readRessoureStatsInternal = getProcessID >>= \pid -> do + cpu <- getMemoryInfo pid + rts <- GhcStats.getRTSStats + mem <- getMemoryInfo pid + pure . Just $ + ResourceStats + { rCentiCpu = timeValToCenti (_user_time cpu) + + timeValToCenti (_system_time cpu) + , rCentiGC = nsToCenti $ GhcStats.gc_cpu_ns rts + , rCentiMut = nsToCenti $ GhcStats.mutator_cpu_ns rts + , rGcsMajor = fromIntegral $ GhcStats.major_gcs rts + , rGcsMinor = fromIntegral $ GhcStats.gcs rts - GhcStats.major_gcs rts + , rAlloc = GhcStats.allocated_bytes rts + , rLive = GhcStats.gcdetails_live_bytes $ GhcStats.gc rts + , rRSS = _resident_size mem + , rCentiBlkIO = 0 + , rThreads = 0 + } + where + nsToCenti :: GhcStats.RtsTime -> Word64 + nsToCenti = fromIntegral . (`div` 10000000) + timeValToCenti :: TIME_VALUE_T -> Word64 + timeValToCenti tv = 10000 `div` (usFromTimeValue tv) + +usFromTimeValue :: TIME_VALUE_T -> Word64 +usFromTimeValue (TIME_VALUE_T s us) = s * 1000000 + us diff --git a/trace-resources/src/Cardano/Logging/Resources/Dummy.hs b/trace-resources/src/Cardano/Logging/Resources/Dummy.hs new file mode 100644 index 00000000000..bcecfa620d4 --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources/Dummy.hs @@ -0,0 +1,33 @@ +module Cardano.Logging.Resources.Dummy + ( + readResourceStatsInternal + ) where + +import Cardano.Logging.Resources +import Data.Word +import qualified GHC.Stats as GhcStats +import System.CPUTime + + +readResourceStatsInternal :: IO ResourceStats +readResourceStatsInternal = do + cpu <- getCPUTime + rts <- GhcStats.getRTSStats + pure $ + ResourceStats + { rCentiCpu = intToCenti cpu + , rCentiGC = nsToCenti $ GhcStats.gc_cpu_ns rts + , rCentiMut = nsToCenti $ GhcStats.mutator_cpu_ns rts + , rGcsMajor = fromIntegral $ GhcStats.major_gcs rts + , rGcsMinor = fromIntegral $ GhcStats.gcs rts - GhcStats.major_gcs rts + , rAlloc = GhcStats.allocated_bytes rts + , rLive = GhcStats.gcdetails_live_bytes $ GhcStats.gc rts + , rRSS = 0 + , rCentiBlkIO = 0 + , rThreads = 0 + } + where + nsToCenti :: GhcStats.RtsTime -> Word64 + nsToCenti = fromIntegral . (`div` 10000000) + intToCenti :: Integer -> Word64 + intToCenti = fromIntegral . (`div` 10000000) diff --git a/trace-resources/src/Cardano/Logging/Resources/Linux.hs b/trace-resources/src/Cardano/Logging/Resources/Linux.hs new file mode 100644 index 00000000000..10d0ac640fe --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources/Linux.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} + +module Cardano.Logging.Resources.Linux + ( + readRessoureStatsInternal + ) where + +import Cardano.Logging.Resources.Types +import Data.Maybe (fromMaybe) +import Data.Word +import qualified GHC.Stats as GhcStats +import System.Posix.Files (fileMode, getFileStatus, + intersectFileModes, + ownerReadMode) +import Text.Read (readMaybe) + +-- | TODO we have to expand the |readMemStats| function +-- to read full data from |proc| +readRessoureStatsInternal :: IO (Maybe ResourceStats) +readRessoureStatsInternal = do + rts <- GhcStats.getRTSStats + mkProcStats rts . fmap fromIntegral <$> readProcList "/proc/self/stat" + where + mkProcStats :: GhcStats.RTSStats -> [Word64] -> Maybe ResourceStats + mkProcStats rts + (_:_:_:_:_:_:_:_:_:_ -- 00-09 + :_:_:_:user:sys:_:_:_:_:threads -- 10-19 + :_:_:_:rss:_:_:_:_:_:_ -- 20-29 + :_:_:_:_:_:_:_:_:_:_ -- 30-39 + :_:blkio:_rest) = -- 40-42 + Just $ ResourceStats + { rCentiCpu = user + sys + , rCentiGC = nsToCenti $ GhcStats.gc_cpu_ns rts + , rCentiMut = nsToCenti $ GhcStats.mutator_cpu_ns rts + , rGcsMajor = fromIntegral $ GhcStats.major_gcs rts + , rGcsMinor = fromIntegral $ GhcStats.gcs rts - GhcStats.major_gcs rts + , rAlloc = GhcStats.allocated_bytes rts + , rLive = GhcStats.gcdetails_live_bytes $ GhcStats.gc rts + , rRSS = rss * 4096 -- TODO: this is really PAGE_SIZE. + , rCentiBlkIO = blkio + , rThreads = threads + } + mkProcStats _ _ = Nothing + nsToCenti :: GhcStats.RtsTime -> Word64 + nsToCenti = floor . (/ (10000000 :: Double)) . fromIntegral + +readProcList :: FilePath -> IO [Integer] +readProcList fp = do + fs <- getFileStatus fp + if readable fs + then do + cs <- readFile fp + return $ map (\s -> fromMaybe 0 (readMaybe s :: Maybe Integer)) (words cs) + else + return [] + where + readable fs = intersectFileModes (fileMode fs) ownerReadMode == ownerReadMode diff --git a/trace-resources/src/Cardano/Logging/Resources/Types.hs b/trace-resources/src/Cardano/Logging/Resources/Types.hs new file mode 100644 index 00000000000..888335664ad --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources/Types.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} + +module Cardano.Logging.Resources.Types + ( + ResourceStats(..) + , docResourceStats + ) where + + +import Cardano.Logging.Types +import Data.Aeson (Value (Number, String), (.=)) +import Data.Text (pack) +import Data.Word + +-- | Struct for resources used by the process +data ResourceStats + = ResourceStats + { rCentiCpu :: !Word64 + , rCentiGC :: !Word64 + , rCentiMut :: !Word64 + , rGcsMajor :: !Word64 + , rGcsMinor :: !Word64 + , rAlloc :: !Word64 + , rLive :: !Word64 + , rRSS :: !Word64 + , rCentiBlkIO :: !Word64 + , rThreads :: !Word64 + } + deriving (Show) + +docResourceStats :: Documented ResourceStats +docResourceStats = Documented [ + DocMsg + (ResourceStats 1 1 1 1 1 1 1 1 1 1) + [(["Stat","Cputicks"], "Reports the CPU ticks, sice the process was started") + ,(["Mem","Resident"], "TODO JNF") + ,(["RTS","GcLiveBytes"],"TODO JNF") + ,(["RTS","GcMajorNum"],"TODO JNF") + ,(["RTS","GcMinorNum"],"TODO JNF") + ,(["RTS","Gcticks"],"TODO JNF") + ,(["RTS","Mutticks"],"TODO JNF") + ,(["RTS","Threads"],"TODO JNF") + ] + "TODO JNF" + ] + +instance LogFormatting ResourceStats where + forHuman rs = "Resources: CpuTicks " <> (pack . show) (rCentiCpu rs) + <> ", Resident " <> (pack . show) (rRSS rs) + <> ", GcLiveBytes " <> (pack . show) (rLive rs) + <> ", GcMajorNum " <> (pack . show) (rGcsMajor rs) + <> ", GcMinorNum " <> (pack . show) (rGcsMinor rs) + <> ", Gcticks " <> (pack . show) (rCentiGC rs) + <> ", Mutticks " <> (pack . show) (rCentiMut rs) + <> ", Threads " <> (pack . show) (rThreads rs) + <> "." + + forMachine _dtal rs = mkObject + [ "kind" .= String "ResourceStats" + , "Cputicks" .= Number (fromIntegral $ rCentiCpu rs) + , "Resident" .= Number (fromIntegral $ rRSS rs) + , "GcLiveBytes" .= Number (fromIntegral $ rLive rs) + , "GcMajorNum" .= Number (fromIntegral $ rGcsMajor rs) + , "GcMinorNum" .= Number (fromIntegral $ rGcsMinor rs) + , "Gcticks" .= Number (fromIntegral $ rCentiGC rs) + , "Mutticks" .= Number (fromIntegral $ rCentiMut rs) + , "Threads" .= Number (fromIntegral $ rThreads rs) + ] + + asMetrics rs = + [ IntM ["Stat","Cputicks"] (fromIntegral $ rCentiCpu rs) + , IntM ["Mem","Resident"] (fromIntegral $ rRSS rs) + , IntM ["RTS","GcLiveBytes"] (fromIntegral $ rLive rs) + , IntM ["RTS","GcMajorNum"] (fromIntegral $ rGcsMajor rs) + , IntM ["RTS","GcMinorNum"] (fromIntegral $ rGcsMinor rs) + , IntM ["RTS","Gcticks"] (fromIntegral $ rCentiGC rs) + , IntM ["RTS","Mutticks"] (fromIntegral $ rCentiMut rs) + , IntM ["Stat","Threads"] (fromIntegral $ rThreads rs) + ] diff --git a/trace-resources/src/Cardano/Logging/Resources/Windows.hsc b/trace-resources/src/Cardano/Logging/Resources/Windows.hsc new file mode 100644 index 00000000000..2f065e73e0f --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources/Windows.hsc @@ -0,0 +1,177 @@ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Logging.Resources.Windows + ( readRessoureStatsInternal + ) where + + +import Data.Word (Word64) +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import qualified GHC.Stats as GhcStats +import System.Win32.Process (ProcessId, getCurrentProcessId) +import System.Win32.Types + +import Cardano.Logging.Resources.Types + + +-- use PsAPI version 2 +#define PSAPI_VERSION 2 + +#include +#include + +#include "os-support-win.h" + + +{- type aliases -} +type ULONGLONG = Word64 + +{- memory information -} + +{- https://docs.microsoft.com/de-de/windows/win32/api/psapi/ns-psapi-process_memory_counters +typedef struct _PROCESS_MEMORY_COUNTERS { + DWORD cb; + DWORD PageFaultCount; + SIZE_T PeakWorkingSetSize; + SIZE_T WorkingSetSize; + SIZE_T QuotaPeakPagedPoolUsage; + SIZE_T QuotaPagedPoolUsage; + SIZE_T QuotaPeakNonPagedPoolUsage; + SIZE_T QuotaNonPagedPoolUsage; + SIZE_T PagefileUsage; + SIZE_T PeakPagefileUsage; +} PROCESS_MEMORY_COUNTERS; -} + +data ProcessMemoryCounters = ProcessMemoryCounters + { _cb :: DWORD + , _pageFaultCount :: DWORD + , _peakWorkingSetSize :: SIZE_T + , _workingSetSize :: SIZE_T + , _quotaPeakPagedPoolUsage :: SIZE_T + , _quotaPagedPoolUsage :: SIZE_T + , _quotaPeakNonPagedPoolUsage :: SIZE_T + , _quotaNonPagedPoolUsage :: SIZE_T + , _pagefileUsage :: SIZE_T + , _peakPagefileUsage :: SIZE_T + } + +instance Storable ProcessMemoryCounters where + alignment _ = #const offsetof(struct {char x__; PROCESS_MEMORY_COUNTERS (y__); }, y__) + sizeOf _ = #size PROCESS_MEMORY_COUNTERS + peek ptr = ProcessMemoryCounters + <$> (#peek PROCESS_MEMORY_COUNTERS, cb) ptr + <*> (#peek PROCESS_MEMORY_COUNTERS, PageFaultCount) ptr + <*> (#peek PROCESS_MEMORY_COUNTERS, PeakWorkingSetSize) ptr + <*> (#peek PROCESS_MEMORY_COUNTERS, WorkingSetSize) ptr + <*> (#peek PROCESS_MEMORY_COUNTERS, QuotaPeakPagedPoolUsage) ptr + <*> (#peek PROCESS_MEMORY_COUNTERS, QuotaPagedPoolUsage) ptr + <*> (#peek PROCESS_MEMORY_COUNTERS, QuotaPeakNonPagedPoolUsage) ptr + <*> (#peek PROCESS_MEMORY_COUNTERS, QuotaNonPagedPoolUsage) ptr + <*> (#peek PROCESS_MEMORY_COUNTERS, PagefileUsage) ptr + <*> (#peek PROCESS_MEMORY_COUNTERS, PeakPagefileUsage) ptr + poke _ _ = pure () + +foreign import ccall unsafe c_get_process_memory_info :: Ptr ProcessMemoryCounters -> CInt -> IO CInt + +{- I/O counters -} +{- https://docs.microsoft.com/de-de/windows/win32/api/winnt/ns-winnt-io_counters +typedef struct _IO_COUNTERS { + ULONGLONG ReadOperationCount; + ULONGLONG WriteOperationCount; + ULONGLONG OtherOperationCount; + ULONGLONG ReadTransferCount; + ULONGLONG WriteTransferCount; + ULONGLONG OtherTransferCount; +} IO_COUNTERS; -} + +data IOCounters = IOCounters + { _readOperationCount :: ULONGLONG + , _writeOperationCount :: ULONGLONG + , _otherOperationCount :: ULONGLONG + , _readTransferCount :: ULONGLONG + , _writeTransferCount :: ULONGLONG + , _otherTransferCount :: ULONGLONG + } + +instance Storable IOCounters where + alignment _ = #const offsetof(struct {char x__; IO_COUNTERS (y__); }, y__) + sizeOf _ = #size IO_COUNTERS + peek ptr = IOCounters + <$> (#peek IO_COUNTERS, ReadOperationCount) ptr + <*> (#peek IO_COUNTERS, WriteOperationCount) ptr + <*> (#peek IO_COUNTERS, OtherOperationCount) ptr + <*> (#peek IO_COUNTERS, ReadTransferCount) ptr + <*> (#peek IO_COUNTERS, WriteTransferCount) ptr + <*> (#peek IO_COUNTERS, OtherTransferCount) ptr + poke _ _ = pure () + +data CpuTimes = CpuTimes { + usertime :: ULONGLONG + , systime :: ULONGLONG + , _idletime :: ULONGLONG + } + +instance Storable CpuTimes where + alignment _ = #const offsetof(struct {char x__; CPU_TIMES (y__); }, y__) + sizeOf _ = #size CPU_TIMES + peek ptr = CpuTimes + <$> (#peek CPU_TIMES, usertime) ptr + <*> (#peek CPU_TIMES, systime) ptr + <*> (#peek CPU_TIMES, idletime) ptr + poke _ _ = pure () + +foreign import ccall unsafe c_get_proc_cpu_times :: Ptr CpuTimes -> CInt -> IO CInt + + +getMemoryInfo :: ProcessId -> IO ProcessMemoryCounters +getMemoryInfo pid = + allocaBytes 128 $ \ptr -> do + res <- c_get_process_memory_info ptr (fromIntegral pid) + if res <= 0 + then do + putStrLn $ "c_get_process_memory_info: failure returned: " ++ (show res) + return $ ProcessMemoryCounters 0 0 0 0 0 0 0 0 0 0 + else + peek ptr + +readRessoureStatsInternal :: IO (Maybe ResourceStats) +readRessoureStatsInternal = getCurrentProcessId >>= \pid -> do + cpu <- getCpuTimes pid + mem <- getMemoryInfo pid + rts <- GhcStats.getRTSStats + pure . Just $ + ResourceStats + { rCentiCpu = usecsToCenti $ usertime cpu + systime cpu + , rCentiGC = nsToCenti $ GhcStats.gc_cpu_ns rts + , rCentiMut = nsToCenti $ GhcStats.mutator_cpu_ns rts + , rGcsMajor = fromIntegral $ GhcStats.major_gcs rts + , rGcsMinor = fromIntegral $ GhcStats.gcs rts - GhcStats.major_gcs rts + , rAlloc = GhcStats.allocated_bytes rts + , rLive = GhcStats.gcdetails_live_bytes $ GhcStats.gc rts + , rRSS = fromIntegral (_workingSetSize mem) + , rCentiBlkIO = 0 + , rThreads = 0 + } + where + usecsToCenti :: ULONGLONG -> Word64 + usecsToCenti ul = ul `div` 10000 + nsToCenti :: GhcStats.RtsTime -> Word64 + nsToCenti = fromIntegral . (`div` 10000000) + + +getCpuTimes :: ProcessId -> IO CpuTimes +getCpuTimes pid = + allocaBytes 128 $ \ptr -> do + res <- c_get_proc_cpu_times ptr (fromIntegral pid) + if res <= 0 + then do + putStrLn $ "c_get_proc_cpu_times: failure returned: " ++ (show res) + return $ CpuTimes 0 0 0 + else + peek ptr diff --git a/trace-resources/src/Cardano/Logging/Resources/os-support-darwin.c b/trace-resources/src/Cardano/Logging/Resources/os-support-darwin.c new file mode 100644 index 00000000000..7806418577e --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources/os-support-darwin.c @@ -0,0 +1,272 @@ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* +// includes for c_get_sys_disk_io_counters +// will require GHC options in cabal file: +// if os(darwin) +// ghc-options: -framework CoreFoundation -framework IOKit +// +#include +#include +#include +#include +#include +#include +#include +*/ +#include "os-support-darwin.h" + + +/* c_get_process_memory_info */ + +int c_get_process_memory_info(struct mach_task_basic_info *counters, int pid) +{ + task_t task = MACH_PORT_NULL; + if (task_for_pid(current_task(), pid, &task) != KERN_SUCCESS) { + return -2; + } + struct mach_task_basic_info t_info; + mach_msg_type_number_t t_info_count = MACH_TASK_BASIC_INFO_COUNT; + if (task_info(task, MACH_TASK_BASIC_INFO, (task_info_t)counters, &t_info_count) != KERN_SUCCESS) { + return -1; + } + return 1; +} + + +/* c_get_host_info */ +/* currently this is not used +int c_get_host_info(struct host_basic_info *counters) +{ + mach_msg_type_number_t count = HOST_BASIC_INFO_COUNT; + mach_port_t host_port = mach_host_self(); + if (host_statistics(host_port, HOST_BASIC_INFO, + (host_info_t)counters, &count) != KERN_SUCCESS) { + return -2; + } + mach_port_deallocate(mach_task_self(), host_port); + return 1; +} */ + +/* c_get_boot_time */ + +long c_get_boot_time() +{ + // copied from psutil + // fetch sysctl "kern.boottime" + static int request[2] = { CTL_KERN, KERN_BOOTTIME }; + struct timeval result; + size_t result_len = sizeof result; + time_t boot_time = 0; + + if (sysctl(request, 2, &result, &result_len, NULL, 0) == -1) { + return -1; + } + return result.tv_sec; +} + +/* c_get_sys_cpu_times */ +int c_get_sys_cpu_times(CPU_TIMES *counters) +{ + mach_msg_type_number_t count = HOST_CPU_LOAD_INFO_COUNT; + host_cpu_load_info_data_t r_load; + + mach_port_t host_port = mach_host_self(); + if (host_statistics(host_port, HOST_CPU_LOAD_INFO, + (host_info_t)&r_load, &count) != KERN_SUCCESS) { + return -2; + } + mach_port_deallocate(mach_task_self(), host_port); + counters->usertime = r_load.cpu_ticks[CPU_STATE_USER] * 100000 / CLK_TCK; + counters->systime = r_load.cpu_ticks[CPU_STATE_SYSTEM] * 100000 / CLK_TCK; + counters->idletime = r_load.cpu_ticks[CPU_STATE_IDLE] * 100000 / CLK_TCK; + counters->nicetime = r_load.cpu_ticks[CPU_STATE_NICE] * 100000 / CLK_TCK; + return 1; +} + +/* c_get_proc_cpu_times */ + + + +/* c_get_sys_disk_io_counters */ +/* adapted from psutil */ +int c_get_sys_disk_io_counters(DISK_COUNTERS *counters) { + counters->ndsks = 0; + // uncomment the following to extract disk I/O metrics + // requires to include the right headers (see top of this file) + // and link to frameworks on Darwin (also described there) +/* + int noutput = 0; + CFDictionaryRef parent_dict; + CFDictionaryRef props_dict; + CFDictionaryRef stats_dict; + io_registry_entry_t parent; + io_registry_entry_t disk; + io_iterator_t disk_list; + + // Get list of disks + if (IOServiceGetMatchingServices( + kIOMasterPortDefault, + IOServiceMatching(kIOMediaClass), + &disk_list) != kIOReturnSuccess) { + return -4; + } + + // Iterate over disks + while ((disk = IOIteratorNext(disk_list)) != 0) { + parent_dict = NULL; + props_dict = NULL; + stats_dict = NULL; + + if (IORegistryEntryGetParentEntry(disk, kIOServicePlane, &parent) != kIOReturnSuccess) { + return -3; + } + + if (IOObjectConformsTo(parent, "IOBlockStorageDriver")) { + + if (IORegistryEntryCreateCFProperties(disk, + (CFMutableDictionaryRef *) &parent_dict, + kCFAllocatorDefault, kNilOptions) != kIOReturnSuccess) { + IOObjectRelease(disk); + IOObjectRelease(parent); + return -2; + } + + if (IORegistryEntryCreateCFProperties(parent, + (CFMutableDictionaryRef *) &props_dict, + kCFAllocatorDefault, kNilOptions) != kIOReturnSuccess) { + CFRelease(props_dict); + IOObjectRelease(disk); + IOObjectRelease(parent); + return -1; + } + + const int kMaxDiskNameSize = 64; + char disk_name[kMaxDiskNameSize+1]; memset(disk_name, 0, kMaxDiskNameSize+1); + CFStringRef disk_name_ref = (CFStringRef) + CFDictionaryGetValue(parent_dict, CFSTR(kIOBSDNameKey)); + CFStringGetCString(disk_name_ref, disk_name, + kMaxDiskNameSize, + CFStringGetSystemEncoding()); + counters->dsknames[noutput] = strdup(disk_name); + + stats_dict = (CFDictionaryRef) + CFDictionaryGetValue(props_dict, CFSTR(kIOBlockStorageDriverStatisticsKey)); + if (stats_dict == NULL) { + continue; + } + CFNumberRef number; + int64_t t_num64 = 0; + // Get disk reads/writes + if ((number = (CFNumberRef)CFDictionaryGetValue(stats_dict, + CFSTR(kIOBlockStorageDriverStatisticsReadsKey)))) { + CFNumberGetValue(number, kCFNumberSInt64Type, &t_num64); + counters->dsks[noutput].reads = t_num64; + } + if ((number = (CFNumberRef)CFDictionaryGetValue(stats_dict, + CFSTR(kIOBlockStorageDriverStatisticsWritesKey)))) { + CFNumberGetValue(number, kCFNumberSInt64Type, &t_num64); + counters->dsks[noutput].writes = t_num64; + } + // Get disk bytes read/written + if ((number = (CFNumberRef)CFDictionaryGetValue(stats_dict, + CFSTR(kIOBlockStorageDriverStatisticsBytesReadKey)))) { + CFNumberGetValue(number, kCFNumberSInt64Type, &t_num64); + counters->dsks[noutput].read_bytes = t_num64; + } + if ((number = (CFNumberRef)CFDictionaryGetValue(stats_dict, + CFSTR(kIOBlockStorageDriverStatisticsBytesWrittenKey)))) { + CFNumberGetValue(number, kCFNumberSInt64Type, &t_num64); + counters->dsks[noutput].write_bytes = t_num64; + } + // Get disk time spent reading/writing (nanoseconds) + if ((number = (CFNumberRef)CFDictionaryGetValue(stats_dict, + CFSTR(kIOBlockStorageDriverStatisticsTotalReadTimeKey)))) { + CFNumberGetValue(number, kCFNumberSInt64Type, &t_num64); + counters->dsks[noutput].read_time = t_num64; + } + if ((number = (CFNumberRef)CFDictionaryGetValue(stats_dict, + CFSTR(kIOBlockStorageDriverStatisticsTotalWriteTimeKey)))) { + CFNumberGetValue(number, kCFNumberSInt64Type, &t_num64); + counters->dsks[noutput].write_time = t_num64; + } + + CFRelease(parent_dict); + IOObjectRelease(parent); + CFRelease(props_dict); + IOObjectRelease(disk); + + noutput++; + if (noutput >= MAX_DISK_COUNTERS) { break; } + } + } // while + IOObjectRelease (disk_list); + counters->ndsks = noutput; +*/ + return 1; +} + +/* c_get_sys_network_io_counters */ +/* adapted from psutil */ +int c_get_sys_network_io_counters(NET_IO *counters) { + counters->nifs = 0; + int noutput = 0; + char *msghdrbuf = NULL, *end_of_list, *next; + struct if_msghdr *ifm; + int mib[6]; + mib[0] = CTL_NET; // networking subsystem + mib[1] = PF_ROUTE; // type of information + mib[2] = 0; // protocol (IPPROTO_xxx) + mib[3] = 0; // address family + mib[4] = NET_RT_IFLIST2; // operation + mib[5] = 0; + size_t buflen; + if (sysctl(mib, 6, NULL, &buflen, NULL, 0) < 0) { + return -4; + } + + msghdrbuf = malloc(buflen); + if (msghdrbuf == NULL) { + return -3; + } + if (sysctl(mib, 6, msghdrbuf, &buflen, NULL, 0) < 0) { + return -2; + } + + char nmbuf[12+1]; + + end_of_list = msghdrbuf + buflen; + for (next = msghdrbuf; next < end_of_list; ) { + ifm = (struct if_msghdr *)next; + next += ifm->ifm_msglen; + if (ifm->ifm_type == RTM_IFINFO2 && (ifm->ifm_flags & IFF_UP)) { + struct if_msghdr2 *if2m = (struct if_msghdr2 *)ifm; + // access name of interface and make a copy of the string + // struct sockaddr_dl *sdl = (struct sockaddr_dl *)(if2m + 1); + // memset(nmbuf, 0, 12+1); + // strncpy(nmbuf, sdl->sdl_data, MIN(12,sdl->sdl_nlen)); + // counters->ifnames[noutput] = strdup(nmbuf); + + // copy struct if_data64 + memcpy(&counters->ifs[noutput], &if2m->ifm_data, sizeof(struct if_data64)); + noutput++; + } + if (noutput >= MAX_NET_IO) { break; } + } + counters->nifs = noutput; + free(msghdrbuf); + return 1; +} diff --git a/trace-resources/src/Cardano/Logging/Resources/os-support-darwin.h b/trace-resources/src/Cardano/Logging/Resources/os-support-darwin.h new file mode 100644 index 00000000000..5898b535218 --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources/os-support-darwin.h @@ -0,0 +1,37 @@ +#include +#include +#include +#include + +typedef struct _CPU_TIMES { + int64_t usertime; + int64_t systime; + int64_t idletime; + int64_t nicetime; +} CPU_TIMES; + +#define MAX_NET_IO 32 +typedef struct _NET_IO { + u_int32_t nifs; + char* ifnames[MAX_NET_IO]; + struct if_data64 ifs[MAX_NET_IO]; +} NET_IO; + +typedef struct _DISK_INFO { + int64_t reads, writes; + int64_t read_bytes, write_bytes; + int64_t read_time, write_time; // nanoseconds +} DISK_INFO; +#define MAX_DISK_COUNTERS 32 +typedef struct _DISK_COUNTERS { + u_int32_t ndsks; + char* dsknames[MAX_DISK_COUNTERS]; + DISK_INFO dsks[MAX_DISK_COUNTERS]; +} DISK_COUNTERS; + +int c_get_process_memory_info (struct mach_task_basic_info *counters, int pid); +//int c_get_host_info (struct host_basic_info *counters); +long c_get_boot_time(); +int c_get_sys_cpu_times(CPU_TIMES *counters); +int c_get_sys_network_io_counters(NET_IO *counters); +int c_get_sys_disk_io_counters(DISK_COUNTERS *counters); \ No newline at end of file diff --git a/trace-resources/src/Cardano/Logging/Resources/os-support-win.c b/trace-resources/src/Cardano/Logging/Resources/os-support-win.c new file mode 100644 index 00000000000..31dbac194fb --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources/os-support-win.c @@ -0,0 +1,94 @@ +#include +#include +//#include + +#include "os-support-win.h" + + +/* c_get_process_memory_info */ + +int c_get_process_memory_info (PROCESS_MEMORY_COUNTERS *counters, DWORD pid) { + HANDLE hProc; + hProc = OpenProcess(PROCESS_QUERY_INFORMATION | PROCESS_VM_READ, + FALSE, pid ); + if (NULL == hProc) { return -2; } + BOOL result = GetProcessMemoryInfo(hProc, counters, sizeof(PROCESS_MEMORY_COUNTERS)); + CloseHandle(hProc); + return result; +} + + +/* c_get_io_counters */ + +int c_get_io_counters (IO_COUNTERS *counters, DWORD pid) { + HANDLE hProc; + hProc = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, + FALSE, pid ); + if (NULL == hProc) { return -2; } + BOOL result = GetProcessIoCounters(hProc, counters); + CloseHandle(hProc); + return result; +} + + +// defined in 'psutil' +// #define LO_T 1e-7 +// #define HI_T 429.4967296 + +/* c_get_sys_cpu_times */ +int c_get_sys_cpu_times (CPU_TIMES *cputimes) { + FILETIME usert={0,0}, kernelt={0,0}, idlet={0,0}; + if (! GetSystemTimes(&idlet, &kernelt, &usert) ) { + return -2; + } + cputimes->usertime = ((ULONGLONG)usert.dwHighDateTime << 32 | usert.dwLowDateTime) / 10; + ULONGLONG kerneltime = ((ULONGLONG)kernelt.dwHighDateTime << 32 | kernelt.dwLowDateTime) / 10; + cputimes->idletime = ((ULONGLONG)idlet.dwHighDateTime << 32 | idlet.dwLowDateTime) / 10; + cputimes->systime = kerneltime - cputimes->idletime; + return 1; +} + +/* c_get_proc_cpu_times */ +int c_get_proc_cpu_times (CPU_TIMES *cputimes, DWORD pid) { + HANDLE hProc; + hProc = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, + FALSE, pid ); + if (NULL == hProc) { return -2; } + FILETIME usert={0,0}, kernelt={0,0}, createt={0,0}, exitt={0,0}; + if (! GetProcessTimes(hProc, &createt, &exitt, &kernelt, &usert) ) { + return -1; + } + CloseHandle(hProc); + /* FILETIME is a structured of two 32 bit counters to form a 64 bit time in 100 ns units */ + /* divide by 10 to get microseconds */ + /* start time: Jan-1 1601 UTC */ + cputimes->usertime = ((ULONGLONG)usert.dwHighDateTime << 32 | usert.dwLowDateTime) / 10; + cputimes->systime = ((ULONGLONG)kernelt.dwHighDateTime << 32 | kernelt.dwLowDateTime) / 10; + // return time since process start in "idletime" + cputimes->idletime = ((ULONGLONG)createt.dwHighDateTime << 32 | createt.dwLowDateTime) / 10; + return 1; +} + +/* c_get_system_info */ +int c_get_system_info (SYSTEM_INFO *sysinfo) { + GetSystemInfo (sysinfo); + return 1; +} + +/* c_get_win_bits */ +int c_get_win_bits (DWORD pid) { + BOOL res; + HANDLE hProc; + hProc = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, + FALSE, pid ); + if (NULL == hProc) { return -2; } + if (! IsWow64Process(hProc, &res)) { + return -1; + } + CloseHandle(hProc); + if (res) { + return 32; + } + return 64; +} + diff --git a/trace-resources/src/Cardano/Logging/Resources/os-support-win.h b/trace-resources/src/Cardano/Logging/Resources/os-support-win.h new file mode 100644 index 00000000000..70da9fdc217 --- /dev/null +++ b/trace-resources/src/Cardano/Logging/Resources/os-support-win.h @@ -0,0 +1,14 @@ + +typedef struct _CPU_TIMES { + ULONGLONG usertime; + ULONGLONG systime; + ULONGLONG idletime; +} CPU_TIMES; + +int c_get_process_memory_info (PROCESS_MEMORY_COUNTERS *counters, DWORD pid); +int c_get_io_counters (IO_COUNTERS *counters, DWORD pid); +int c_get_sys_cpu_times (CPU_TIMES *cputimes); +int c_get_proc_cpu_times (CPU_TIMES *cputimes, DWORD pid); +int c_get_system_info (SYSTEM_INFO *sysinfo); +int c_get_win_bits (DWORD pid); + diff --git a/trace-resources/test/trace-resources-test.hs b/trace-resources/test/trace-resources-test.hs new file mode 100644 index 00000000000..fffb91ad516 --- /dev/null +++ b/trace-resources/test/trace-resources-test.hs @@ -0,0 +1,60 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + +import Control.Monad.IO.Class +import Data.IORef +import Test.Tasty +import Test.Tasty.QuickCheck + +import Cardano.Logging +import Cardano.Logging.Resources +import Cardano.Logging.Resources.Types + + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = localOption (QuickCheckTests 10) $ testGroup "trace-resources" + [ testProperty "resources available" playScript + ] + +-- | Plays a script in a single thread +playScript :: Property +playScript = ioProperty $ do + stdoutTrRef <- newIORef [] + stdoutTracer' <- testTracer stdoutTrRef + forwardTrRef <- newIORef [] + forwardTracer' <- testTracer forwardTrRef + ekgTrRef <- newIORef [] + ekgTracer' <- testTracer ekgTrRef + tr <- mkCardanoTracer + stdoutTracer' + forwardTracer' + (Just ekgTracer') + "Test" + (const ["ResourceStats"]) + (const Info) + (const Public) + configureTracers emptyTraceConfig docResourceStats [tr] + traceIt tr 10 + +traceIt :: Trace IO ResourceStats -> Int -> IO Bool +traceIt _ 0 = pure True +traceIt tr n = do + mbResources <- readResourceStats + case mbResources of + Nothing -> pure False + Just res -> do + traceWith tr res + traceIt tr (n - 1) + + +testTracer :: MonadIO m + => IORef [FormattedMessage] + -> m (Trace m FormattedMessage) +testTracer ioRef = liftIO $ do + pure $ Trace $ arrow $ emit output' + where + output' (LoggingContext{}, Nothing, msg) = liftIO $ do + modifyIORef ioRef (msg :) + output' (LoggingContext{}, _, _) = pure () diff --git a/trace-resources/trace-resources.cabal b/trace-resources/trace-resources.cabal new file mode 100644 index 00000000000..01cf350a275 --- /dev/null +++ b/trace-resources/trace-resources.cabal @@ -0,0 +1,76 @@ +cabal-version: 2.4 +name: trace-resources +version: 0.1.0.0 + +synopsis: Package for tracing resources for linux, mac and windows +author: Juergen Nicklisch-Franken +maintainer: operations@iohk.io +copyright: 2021 IOHK +extra-source-files: CHANGELOG.md + README.md + src/Cardano/Logging/Resources/os-support-darwin.h + src/Cardano/Logging/Resources/os-support-win.h + +library + hs-source-dirs: src + exposed-modules: Cardano.Logging.Resources + Cardano.Logging.Resources.Types + + default-language: Haskell2010 + default-extensions: OverloadedStrings + build-depends: base >=4.12 && <5 + , trace-dispatcher + , text + , aeson + + if os(windows) + build-depends: Win32 + else + build-depends: unix + + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wno-incomplete-patterns + + if os(linux) + exposed-modules: Cardano.Logging.Resources.Linux + if os(windows) + exposed-modules: Cardano.Logging.Resources.Windows + c-sources: src/Cardano/Logging/Resources/os-support-win.c + include-dirs: src/Cardano/Logging/Resources/ + cc-options: -DPSAPI_VERSION=2 + if os(darwin) + exposed-modules: Cardano.Logging.Resources.Darwin + c-sources: src/Cardano/Logging/Resources/os-support-darwin.c + include-dirs: src/Cardano/Logging/Resources/ + +test-suite trace-resources-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: trace-resources-test.hs + default-language: Haskell2010 + default-extensions: OverloadedStrings + build-depends: base >=4.12 && <5 + , trace-dispatcher + , text + , aeson + , QuickCheck + , tasty + , tasty-quickcheck + , trace-resources + ghc-options: "-with-rtsopts=-T" + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wno-incomplete-patterns From 3ecc47cfd67c68f5c7369663ced538e548b1c19b Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Mon, 6 Sep 2021 15:12:06 +0200 Subject: [PATCH 02/12] Documentation review changes. --- trace-dispatcher/CHANGELOG.md | 4 ++-- trace-dispatcher/README.md | 5 +++++ trace-dispatcher/doc/trace-dispatcher.md | 27 ++++++++++++++---------- trace-dispatcher/trace-dispatcher.cabal | 2 +- 4 files changed, 24 insertions(+), 14 deletions(-) diff --git a/trace-dispatcher/CHANGELOG.md b/trace-dispatcher/CHANGELOG.md index 9ef8d24bdba..dd1a6b9dc70 100644 --- a/trace-dispatcher/CHANGELOG.md +++ b/trace-dispatcher/CHANGELOG.md @@ -1,5 +1,5 @@ # Revision history for trace-dispatcher -## 0.1.0.0 -- YYYY-mm-dd +## 1.29.0 -- September 2021 -* First version. Released on an unsuspecting world. +* Initial version. diff --git a/trace-dispatcher/README.md b/trace-dispatcher/README.md index 02e1bf05112..97a32221f38 100644 --- a/trace-dispatcher/README.md +++ b/trace-dispatcher/README.md @@ -5,3 +5,8 @@ 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 + +## Developers + +Benchmarking team is responsible for this library. +The primary developer is [@JürgenNF](https://github.com/jutaro). diff --git a/trace-dispatcher/doc/trace-dispatcher.md b/trace-dispatcher/doc/trace-dispatcher.md index cbd4b01a781..361797860ab 100644 --- a/trace-dispatcher/doc/trace-dispatcher.md +++ b/trace-dispatcher/doc/trace-dispatcher.md @@ -78,7 +78,7 @@ Key design decisions were: 3. Separation of data plane and control plane: high-frequency events incur minimal processing on the data-plane, whereas complicated configuration logic only happens on the control plane, and that is proportional to infrequent reconfiguration events. 4. A tougher stance on separation of concerns in the backend side: we choose to move expensive trace processing to an external process. 5. A measure of backward compatibility with the previous logging system. -6. Retaining the global namespace for all traces. +6. Retaining a global namespace for all traces. ## Overview and terminology @@ -88,7 +88,7 @@ Therefore, we can conceptually decompose the __tracing system__ into three compo * __frontend__, the entry point for __program trace__ collection, which is just a single function `traceWith`; Program locations that invoke this frontend (thereby injecting messages into the tracing system) is called __trace-ins__. * __dispatcher__, is a structured, namespaced set of contravariantly-composed transformations, triggered by the entry point. Its role is specifically __trace interpretation__; -* __backend__, externalises results of the interpretation ( __metrics__ and __messages__) outside the system, through __trace-outs__. +* __backend__, externalises results of the interpretation ( __metrics__ and __messages__) outside the tracing system, through __trace-outs__. The trace-emitting program itself is only exposed to the the frontend part of the tracing system, as it only needs to define the traces themselves, and specify the __trace-ins__ -- call sites that inject traces. It is notably free from any extra obligations, such as the need to define the `LogFormatting` instances. @@ -128,7 +128,7 @@ data TraceAddBlockEvent blk = ... ``` -__Traces__ cannot be entered into the tracing system, unless they are accompanied by a matching __tracer__ -- a monadic callback, that expresses the action of tracing of values of that particular type: +__Traces__ cannot be entered into the tracing system, unless they are accompanied by a matching __Trace__ -- a monadic callback, that expresses the action of tracing of values of that particular type: ```haskell trAddBlock :: Trace IO (TraceAddBlockEvent blk) @@ -192,7 +192,7 @@ The __logging context__ of the trace is defined as follows: 1. __trace filtering__ -- by __privacy__, __severity__ and __namespace__ context, 2. __trace presentation__ -- by __detail level__ context. -Severity an detail level can be configured. +Severity and detail level can be configured. ## Filter context ### Severity @@ -256,7 +256,7 @@ withPrivacy :: Monad m => (a -> Privacy) -> Trace m a -> Trace m a Trace privacy cannot be configured. -See [Confidentiality and privacy filtering implementation](#Confidentiality-and-privacy -filtering-implementation) for a more full discussion of semantics. +See [Confidentiality and privacy filtering implementation](#Confidentiality-and-privacy-filtering-implementation) for a more full discussion of semantics. To further prevent occasional leaks of `Confidential` traces, all output from those traces is tagged with the `CONFIDENTIAL` keyword. @@ -268,7 +268,7 @@ Semantically, this is corresponds to a randomly-fair suppression of messages wit The __frequency limiter__ itself emits a __suppression summary__ message under the following conditions: -* when it message suppression begins, and +* when message suppression begins, and * when message suppression stops -- adding the number of suppressed messages. __Frequency limiters__ are given a name to identify its activity. @@ -294,15 +294,15 @@ The frequency filtering is intended to be applied to a subset of traces (those k The `LogFormatting` typeclass is used to describe __trace presentation__ -- mapping __traces__ to __metrics__ and __messages__. -* The `forMachine` method is used for a machine readable representation, which can varied through detail level. +* The `forMachine` method is used for a machine readable representation, which can be varied through detail level. It requires an implementation to be provided by the trace author. * the `forHuman` method shall represent the message in human readable form. It's default implementation defers to `forMachine`. * the `asMetrics` method shall represent the message as `0` to `n` metrics. - It's default implementation assumes no metrics. If a text is given it is - appended as last element to the namespace. + It's default implementation assumes no metrics. Each metric can optionally + specify a namespace as a `[Text]`. ```haskell class LogFormatting a where @@ -329,21 +329,26 @@ data FormattedMessage | Metrics [Metric] ``` -`humanFormatter` takes a `Bool` argument, which tells if color codes for the standard output __trace-out__ shall be inserted, and an argument which is the app name, which gets prepended to the namespace, while the `machineFormatter` has as arguments the desired detail level and as well the application name. `metricsFormatter` takes no extra arguments: - ```haskell +-- | Format this trace for human readability +-- The boolean value tells, if this representation is for the console and should be colored. +-- The text argument gives the application name which is prepended to the namespace. humanFormatter :: (LogFormatting a, MonadIO m) => Bool -> Text -> Trace m FormattedMessage -> m (Trace m a) +-- | Format this trace for machine readability. +-- The detail level give a hint to the formatter. +-- The text argument gives the application name which is prepended to the namespace. machineFormatter :: (LogFormatting a, MonadIO m) => DetailLevel -> Text -> Trace m FormattedMessage -> m (Trace m a) +-- | Format this trace as metrics metricsFormatter :: (LogFormatting a, MonadIO m) => Trace m FormattedMessage -> m (Trace m a) diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal index a4ca509e179..224732c202a 100644 --- a/trace-dispatcher/trace-dispatcher.cabal +++ b/trace-dispatcher/trace-dispatcher.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: trace-dispatcher -version: 0.1.0.0 +version: 1.29.0 synopsis: Package for development of simple and efficient tracers based on the arrow based contra-tracer package From a8bba2c1be7ee371608d0d7ed8f2a1d4be4f344a Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Tue, 7 Sep 2021 13:04:21 +0200 Subject: [PATCH 03/12] More documentation review changes --- trace-dispatcher/doc/trace-dispatcher.md | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/trace-dispatcher/doc/trace-dispatcher.md b/trace-dispatcher/doc/trace-dispatcher.md index 361797860ab..96a0ff71af8 100644 --- a/trace-dispatcher/doc/trace-dispatcher.md +++ b/trace-dispatcher/doc/trace-dispatcher.md @@ -105,7 +105,7 @@ __Trace interpretation__ is specified in terms of: The __trace interpretation__ process requires that for each traced type the __dispatcher__ is provided with: * instances of the `LogFormatting` typeclass, and -* __trace prototypes__ and __trace documentation__. +* __message prototypes__ and __trace documentation__. __Trace interpretation__ would have been unusably static, if it wasn't allowed to be configured without recompilation -- and therefore the __effective tracing policy__ used by the __dispatcher__ can be partially defined by the externally-supplied __trace configuration__. @@ -192,7 +192,7 @@ The __logging context__ of the trace is defined as follows: 1. __trace filtering__ -- by __privacy__, __severity__ and __namespace__ context, 2. __trace presentation__ -- by __detail level__ context. -Severity and detail level can be configured. +Severity an detail level can be configured. ## Filter context ### Severity @@ -268,7 +268,7 @@ Semantically, this is corresponds to a randomly-fair suppression of messages wit The __frequency limiter__ itself emits a __suppression summary__ message under the following conditions: -* when message suppression begins, and +* when it message suppression begins, and * when message suppression stops -- adding the number of suppressed messages. __Frequency limiters__ are given a name to identify its activity. @@ -376,7 +376,7 @@ If aggregated information from multiple consecutive messages is needed the follo ```haskell --- | Folds the function with state b over messages a in the trace. +-- | Folds the function with state acc over messages a in the trace. foldTraceM :: MonadIO m => (acc -> a -> acc) -> acc @@ -447,7 +447,7 @@ To route one trace to multiple tracers simultaneously we use the fact that Trace mconcat :: Monoid m => [m] -> m ``` -In the third example we unite two traces to one tracer, for which we trivially use the same tracer on the right side. +In the next example we unite two traces to one tracer, for which we trivially use the same tracer on the right side. ```haskell tracer1 = appendName "tracer1" exTracer @@ -499,7 +499,7 @@ data TraceConfig = TraceConfig { ``` If the configuration file is in Yaml format, the following entry means, that by default -all messages with Info or higher Priority or higher are shown: +all messages with Info or higher Priority are shown: ```yaml TraceOptionSeverity: @@ -548,7 +548,7 @@ The self-documentation features of `trace-dispatcher` are provided by a combinat The per- __message__ `DocMsg` objects combine: -* __trace prototypes__ -- a stubbed __message__ invocation, +* __message prototypes__ -- an example __message__, * message documentation text, in Markdown format, *Because it is not enforced by the type system, it is very important that each trace provides a complete list of `DocMsg` entries for all message contructors, as these prototypes are also used for configuration*. @@ -736,7 +736,7 @@ DECISION: there is value in maintaining a user-friendly trace message namespace. ### Decide inline trace type annotation with trace function 2 -DECISION: we use `traceWith` in the library code and `traceNamed` in th dispatcher. +DECISION: we use `traceWith` in the library code and `traceNamed` in the dispatcher. > Since we require that every message has its unique name we encourage the use of the already introduced convenience function: > From 86989b74d2cd3bc252cb89bc928523d903083c8a Mon Sep 17 00:00:00 2001 From: Kosyrev Serge Date: Wed, 8 Sep 2021 19:07:55 +0300 Subject: [PATCH 04/12] tracing docs: clarify control-vs.-data plane in README --- trace-dispatcher/doc/trace-dispatcher.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/trace-dispatcher/doc/trace-dispatcher.md b/trace-dispatcher/doc/trace-dispatcher.md index 96a0ff71af8..1be2fba8274 100644 --- a/trace-dispatcher/doc/trace-dispatcher.md +++ b/trace-dispatcher/doc/trace-dispatcher.md @@ -75,7 +75,7 @@ Key design decisions were: 1. Retaining the separation of concerns in the frontend side, as provided by the `contra-tracer` library. The client code should not need to concern itself with any details beyond passing the traces down to the system. 2. Rely on __trace combinators__ primarily, as opposed to opting for a typeclass heavy API. -3. Separation of data plane and control plane: high-frequency events incur minimal processing on the data-plane, whereas complicated configuration logic only happens on the control plane, and that is proportional to infrequent reconfiguration events. +3. Separation of data plane and control plane: high-frequency events of the data-plane (corresponding to actual trace emission), whereas complicated configuration-induced logic of the control plane is proportional to infrequent reconfiguration events. This is the principle we tried to ensure across the system -- and hopefully succeeded to a reasonable degree. 4. A tougher stance on separation of concerns in the backend side: we choose to move expensive trace processing to an external process. 5. A measure of backward compatibility with the previous logging system. 6. Retaining a global namespace for all traces. From ffb71a5b4911afc660b6e0e477b9f54ced7e23e9 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Fri, 10 Sep 2021 13:19:55 +0200 Subject: [PATCH 05/12] With multithreaded reconfiguration tests -1- --- .../src/Cardano/Logging/Configuration.hs | 3 +- .../test/Cardano/Logging/Test/Oracles.hs | 6 +- .../test/Cardano/Logging/Test/Script.hs | 358 ++++++++++++++---- .../test/Cardano/Logging/Test/Types.hs | 9 + .../test/trace-dispatcher-test.hs | 12 +- 5 files changed, 302 insertions(+), 86 deletions(-) diff --git a/trace-dispatcher/src/Cardano/Logging/Configuration.hs b/trace-dispatcher/src/Cardano/Logging/Configuration.hs index 1699a6b03d5..9af38c53760 100644 --- a/trace-dispatcher/src/Cardano/Logging/Configuration.hs +++ b/trace-dispatcher/src/Cardano/Logging/Configuration.hs @@ -98,7 +98,8 @@ withNamespaceConfig name extract withConfig tr = do Nothing -> do tt <- withConfig (Just v) tr T.traceWith (unpackTrace tt) (lc, Nothing, a) - Left (_cmap, Nothing) -> error ("Missing configuration " <> name <> " ns " <> show (lcNamespace lc)) + Left (_cmap, Nothing) -> pure () + -- This can happen during reconfiguration, so we don't throw an error any more mkTrace ref (lc, Just Reset, a) = do -- trace ("mkTrace Reset " <> show (lcNamespace lc)) $ pure () liftIO $ writeIORef ref (Left (Map.empty, Nothing)) diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs b/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs index 8a82b3fb42c..689ba1de733 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Logging.Test.Oracles ( - oracleFiltering + oracleMessages , occurences ) where @@ -19,8 +19,8 @@ import Debug.Trace -- | Checks for every message that it appears or does not appear at the right -- backend. Tests filtering and routing to backends -oracleFiltering :: TraceConfig -> ScriptRes -> Property -oracleFiltering conf ScriptRes {..} = +oracleMessages :: TraceConfig -> ScriptRes -> Property +oracleMessages conf ScriptRes {..} = let Script msgs = srScript in property $ all oracleMessage msgs where diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Script.hs b/trace-dispatcher/test/Cardano/Logging/Test/Script.hs index 86c3fa88447..1344a1a8c2e 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Script.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Script.hs @@ -1,20 +1,23 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} - module Cardano.Logging.Test.Script ( runScriptSimple , runScriptMultithreaded + , runScriptMultithreadedWithReconfig + , runScriptMultithreadedWithConstantReconfig ) where import Control.Concurrent (ThreadId, forkFinally, threadDelay) import Control.Concurrent.MVar import Control.Exception.Base (SomeException, throw) -import Control.Monad (when) +import Control.Monad (liftM2, when) import Data.IORef (newIORef, readIORef) import Data.List (sort) import Data.Maybe (mapMaybe) +import Data.Time.Clock.System import Test.QuickCheck import Cardano.Logging @@ -23,7 +26,7 @@ import Cardano.Logging.Test.Messages import Cardano.Logging.Test.Tracer import Cardano.Logging.Test.Types -import Debug.Trace +-- import Debug.Trace -- | Run a script in a single thread and uses the oracle to test for correctness @@ -34,8 +37,34 @@ runScriptSimple :: -> Property runScriptSimple time oracle = do let generator :: Gen (Script, TraceConfig) = arbitrary - forAll generator (\ (script,conf) -> ioProperty $ do - scriptResult <- playScript time conf 0 script + forAll generator (\ (Script msgs,conf) -> ioProperty $ do + stdoutTrRef <- newIORef [] + stdoutTracer' <- testTracer stdoutTrRef + forwardTrRef <- newIORef [] + forwardTracer' <- testTracer forwardTrRef + ekgTrRef <- newIORef [] + ekgTracer' <- testTracer ekgTrRef + tr <- mkCardanoTracer + stdoutTracer' + forwardTracer' + (Just ekgTracer') + "Test" + namesForMessage + severityForMessage + privacyForMessage + configureTracers conf docMessage [tr] + let sortedMsgs = sort msgs + let (msgsWithIds,_) = withMessageIds 0 sortedMsgs + let timedMessages = map (withTimeFactor time) msgsWithIds + playIt (Script timedMessages) tr 0.0 + r1 <- readIORef stdoutTrRef + r2 <- readIORef forwardTrRef + r3 <- readIORef ekgTrRef + let scriptResult = ScriptRes + (Script timedMessages) + (reverse r1) + (reverse r2) + (reverse r3) -- trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) -- <> " forwardTrRes " <> show (srForwardRes scriptResult) -- <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ @@ -51,18 +80,112 @@ runScriptMultithreaded :: -> Property runScriptMultithreaded time oracle = do let generator :: Gen (Script, Script, Script, TraceConfig) = arbitrary - forAll generator (\ (script1, script2, script3, conf) -> ioProperty $ do - children :: MVar [MVar (Either SomeException ScriptRes)] <- newMVar [] - _ <- forkChild children (playScript time conf 0 script1) - let start1 = scriptLength script1 - _ <- forkChild children (playScript time conf start1 script2) - let start2 = start1 + scriptLength script2 - _ <- forkChild children (playScript time conf start2 script3) + forAll generator (\ (Script msgs1, Script msgs2, Script msgs3, conf) + -> ioProperty $ do + stdoutTrRef <- newIORef [] + stdoutTracer' <- testTracer stdoutTrRef + forwardTrRef <- newIORef [] + forwardTracer' <- testTracer forwardTrRef + ekgTrRef <- newIORef [] + ekgTracer' <- testTracer ekgTrRef + tr <- mkCardanoTracer + stdoutTracer' + forwardTracer' + (Just ekgTracer') + "Test" + namesForMessage + severityForMessage + privacyForMessage + configureTracers conf docMessage [tr] + let sortedMsgs1 = sort msgs1 + let (msgsWithIds1,_) = withMessageIds 0 sortedMsgs1 + let timedMessages1 = map (withTimeFactor time) msgsWithIds1 + let start1 = length timedMessages1 + let sortedMsgs2 = sort msgs2 + let (msgsWithIds2,_) = withMessageIds start1 sortedMsgs2 + let timedMessages2 = map (withTimeFactor time) msgsWithIds2 + let start2 = start1 + length timedMessages2 + let sortedMsgs3 = sort msgs3 + let (msgsWithIds3,_) = withMessageIds start2 sortedMsgs3 + let timedMessages3 = map (withTimeFactor time) msgsWithIds3 + + children :: MVar [MVar (Either SomeException ())] <- newMVar [] + _ <- forkChild children (playIt (Script timedMessages1) tr 0.0) + + _ <- forkChild children (playIt (Script timedMessages2) tr 0.0) + + _ <- forkChild children (playIt (Script timedMessages3) tr 0.0) res <- waitForChildren children [] - let res' = mapMaybe + let resErr = mapMaybe (\case - Right rR -> Just rR - Left _ -> Nothing) res + Right _ -> Nothing + Left err -> Just err) res + if not (null resErr) + then throw (head resErr) + else do + r1 <- readIORef stdoutTrRef + r2 <- readIORef forwardTrRef + r3 <- readIORef ekgTrRef + let timedMessages = timedMessages1 ++ timedMessages2 ++ timedMessages3 + scriptResult = ScriptRes + (Script timedMessages) + (reverse r1) + (reverse r2) + (reverse r3) + -- trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) + -- <> " forwardTrRes " <> show (srForwardRes scriptResult) + -- <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ + pure $ oracle conf scriptResult) + +-- | Run three scripts in three threads in parallel +-- and use the oracle to test for correctness. +-- The duration of the test is given by time in seconds +runScriptMultithreadedWithReconfig :: + Double + -> (TraceConfig -> ScriptRes -> Property) + -> Property +runScriptMultithreadedWithReconfig time oracle = do + let generator :: Gen (Script, Script, Script, TraceConfig, TraceConfig) + = arbitrary + reconfigTimeGen = choose (0.0, time) + generator' = liftM2 (,) generator reconfigTimeGen + forAll generator' + (\ ((Script msgs1, Script msgs2, Script msgs3, conf, conf2), reconfigTime) -> + ioProperty $ do + stdoutTrRef <- newIORef [] + stdoutTracer' <- testTracer stdoutTrRef + forwardTrRef <- newIORef [] + forwardTracer' <- testTracer forwardTrRef + ekgTrRef <- newIORef [] + ekgTracer' <- testTracer ekgTrRef + tr <- mkCardanoTracer + stdoutTracer' + forwardTracer' + (Just ekgTracer') + "Test" + namesForMessage + severityForMessage + privacyForMessage + configureTracers conf docMessage [tr] + let sortedMsgs1 = sort msgs1 + let (msgsWithIds1,_) = withMessageIds 0 sortedMsgs1 + let timedMessages1 = map (withTimeFactor time) msgsWithIds1 + let start1 = length timedMessages1 + let sortedMsgs2 = sort msgs2 + let (msgsWithIds2,_) = withMessageIds start1 sortedMsgs2 + let timedMessages2 = map (withTimeFactor time) msgsWithIds2 + let start2 = start1 + length timedMessages2 + let sortedMsgs3 = sort msgs3 + let (msgsWithIds3,_) = withMessageIds start2 sortedMsgs3 + let timedMessages3 = map (withTimeFactor time) msgsWithIds3 + + children :: MVar [MVar (Either SomeException ())] <- newMVar [] + _ <- forkChild children (playIt (Script timedMessages1) tr 0.0) + _ <- forkChild children (playIt (Script timedMessages2) tr 0.0) + _ <- forkChild children (playIt (Script timedMessages3) tr 0.0) + _ <- forkChild children (playReconfigure reconfigTime conf2 tr) + + res <- waitForChildren children [] let resErr = mapMaybe (\case Right _ -> Nothing @@ -70,64 +193,143 @@ runScriptMultithreaded time oracle = do if not (null resErr) then throw (head resErr) else do - let scriptResult = mergeResults res' - trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) - <> " forwardTrRes " <> show (srForwardRes scriptResult) - <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ - pure $ oracle conf scriptResult) - where - forkChild :: MVar [MVar (Either SomeException ScriptRes)] -> IO ScriptRes -> IO ThreadId - forkChild children io = do - mvar <- newEmptyMVar - childs <- takeMVar children - putMVar children (mvar:childs) - forkFinally io (putMVar mvar) - waitForChildren :: MVar [MVar (Either SomeException ScriptRes)] - -> [Either SomeException ScriptRes] - -> IO [Either SomeException ScriptRes] - waitForChildren children accum = do - cs <- takeMVar children - case cs of - [] -> pure accum - m:ms -> do - putMVar children ms - res <- takeMVar m - waitForChildren children (res : accum) + r1 <- readIORef stdoutTrRef + r2 <- readIORef forwardTrRef + r3 <- readIORef ekgTrRef + let timedMessages = timedMessages1 ++ timedMessages2 ++ timedMessages3 + scriptResult = ScriptRes + (Script timedMessages) + (reverse r1) + (reverse r2) + (reverse r3) + -- trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) + -- <> " forwardTrRes " <> show (srForwardRes scriptResult) + -- <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ + pure $ oracle conf scriptResult) + +-- | Run three scripts in three threads in parallel +-- and use the oracle to test for correctness. +-- The duration of the test is given by time in seconds +runScriptMultithreadedWithConstantReconfig :: + Double + -> (TraceConfig -> ScriptRes -> Property) + -> Property +runScriptMultithreadedWithConstantReconfig time oracle = do + let generator :: Gen (Script, Script, Script, TraceConfig, TraceConfig) + = arbitrary + forAll generator + (\ (Script msgs1, Script msgs2, Script msgs3, conf1, conf2) -> + ioProperty $ do + stdoutTrRef <- newIORef [] + stdoutTracer' <- testTracer stdoutTrRef + forwardTrRef <- newIORef [] + forwardTracer' <- testTracer forwardTrRef + ekgTrRef <- newIORef [] + ekgTracer' <- testTracer ekgTrRef + tr <- mkCardanoTracer + stdoutTracer' + forwardTracer' + (Just ekgTracer') + "Test" + namesForMessage + severityForMessage + privacyForMessage + configureTracers conf1 docMessage [tr] + let sortedMsgs1 = sort msgs1 + let (msgsWithIds1,_) = withMessageIds 0 sortedMsgs1 + let timedMessages1 = map (withTimeFactor time) msgsWithIds1 + let start1 = length timedMessages1 + let sortedMsgs2 = sort msgs2 + let (msgsWithIds2,_) = withMessageIds start1 sortedMsgs2 + let timedMessages2 = map (withTimeFactor time) msgsWithIds2 + let start2 = start1 + length timedMessages2 + let sortedMsgs3 = sort msgs3 + let (msgsWithIds3,_) = withMessageIds start2 sortedMsgs3 + let timedMessages3 = map (withTimeFactor time) msgsWithIds3 + children :: MVar [MVar (Either SomeException ())] <- newMVar [] + _ <- forkChild children (playIt (Script timedMessages1) tr 0.0) + _ <- forkChild children (playIt (Script timedMessages2) tr 0.0) + _ <- forkChild children (playIt (Script timedMessages3) tr 0.0) + _ <- forkChild children (playReconfigureContinuously time conf1 conf2 tr) + + res <- waitForChildren children [] + let resErr = mapMaybe + (\case + Right _ -> Nothing + Left err -> Just err) res + if not (null resErr) + then throw (head resErr) + else do + r1 <- readIORef stdoutTrRef + r2 <- readIORef forwardTrRef + r3 <- readIORef ekgTrRef + let timedMessages = timedMessages1 ++ timedMessages2 ++ timedMessages3 + scriptResult = ScriptRes + (Script timedMessages) + (reverse r1) + (reverse r2) + (reverse r3) + -- trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) + -- <> " forwardTrRes " <> show (srForwardRes scriptResult) + -- <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ + pure $ oracle conf2 scriptResult) + + +forkChild :: MVar [MVar (Either SomeException ())] -> IO () -> IO ThreadId +forkChild children io = do + mvar <- newEmptyMVar + childs <- takeMVar children + putMVar children (mvar:childs) + forkFinally io (putMVar mvar) + +waitForChildren :: MVar [MVar (Either SomeException ())] + -> [Either SomeException ()] + -> IO [Either SomeException ()] +waitForChildren children accum = do + cs <- takeMVar children + case cs of + [] -> pure accum + m:ms -> do + putMVar children ms + res <- takeMVar m + waitForChildren children (res : accum) -- | Plays a script in a single thread -playScript :: Double -> TraceConfig -> Int -> Script -> IO ScriptRes -playScript time config firstId (Script msgs) = do - stdoutTrRef <- newIORef [] - stdoutTracer' <- testTracer stdoutTrRef - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - ekgTrRef <- newIORef [] - ekgTracer' <- testTracer ekgTrRef - tr <- mkCardanoTracer - stdoutTracer' - forwardTracer' - (Just ekgTracer') - "Test" - namesForMessage - severityForMessage - privacyForMessage - - let sortedMsgs = sort msgs - let (msgsWithIds,_) = withMessageIds firstId sortedMsgs - let timedMessages = map (withTimeFactor time) msgsWithIds +playReconfigure :: Double -> TraceConfig -> Trace IO Message -> IO () +playReconfigure time config tr = do + threadDelay (round (time * 1000000)) configureTracers config docMessage [tr] - -- trace ("playScript " <> show timedMessages) $ - playIt (Script timedMessages) tr 0.0 - r1 <- readIORef stdoutTrRef - r2 <- readIORef forwardTrRef - r3 <- readIORef ekgTrRef - pure (ScriptRes - (Script timedMessages) - (reverse r1) - (reverse r2) - (reverse r3)) + +playReconfigureContinuously :: + Double + -> TraceConfig + -> TraceConfig + -> Trace IO Message + -> IO () +playReconfigureContinuously time config1 config2 tr = do + startTime <- systemTimeToSeconds <$> getSystemTime + go startTime 0 + where + go :: Double -> Int -> IO () + go startTime alt = do + timeNow <- systemTimeToSeconds <$> getSystemTime + if timeNow - startTime > time + then pure () + else if alt == 0 + then do + configureTracers config1 docMessage [tr] + go startTime 1 + else do + configureTracers config2 docMessage [tr] + go startTime 0 + + + systemTimeToSeconds :: SystemTime -> Double + systemTimeToSeconds MkSystemTime {..} = + fromIntegral systemSeconds + fromIntegral systemNanoseconds * 1.0E-9 + -- | Play the current script in one thread -- The time is in milliseconds @@ -154,13 +356,13 @@ withTimeFactor :: Double -> ScriptedMessage -> ScriptedMessage withTimeFactor factor (ScriptedMessage time msg) = ScriptedMessage (time * factor) msg -mergeResults :: [ScriptRes] -> ScriptRes -mergeResults results = - let script = Script $ - concatMap - (\r -> case srScript r of - Script scriptedList -> scriptedList) results - stdOutRes = concatMap srStdoutRes results - forwardRes = concatMap srForwardRes results - ekgRes = concatMap srEkgRes results - in ScriptRes script stdOutRes forwardRes ekgRes +-- mergeResults :: [ScriptRes] -> ScriptRes +-- mergeResults results = +-- let script = Script $ +-- concatMap +-- (\r -> case srScript r of +-- Script scriptedList -> scriptedList) results +-- stdOutRes = concatMap srStdoutRes results +-- forwardRes = concatMap srForwardRes results +-- ekgRes = concatMap srEkgRes results +-- in ScriptRes script stdOutRes forwardRes ekgRes diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs index 88d1f0f59c5..5cbbab90dfd 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs @@ -5,6 +5,7 @@ module Cardano.Logging.Test.Types ( , Script (..) , ScriptRes (..) , scriptLength + , emptyScriptRes ) where import Data.Aeson (Value (..), (.=)) @@ -90,3 +91,11 @@ data ScriptRes = ScriptRes { , srForwardRes :: [FormattedMessage] , srEkgRes :: [FormattedMessage] } + +emptyScriptRes :: ScriptRes +emptyScriptRes = ScriptRes { + srScript = Script [] + , srStdoutRes = [] + , srForwardRes = [] + , srEkgRes = [] +} diff --git a/trace-dispatcher/test/trace-dispatcher-test.hs b/trace-dispatcher/test/trace-dispatcher-test.hs index 36af3c9629a..0cb3a014ce1 100644 --- a/trace-dispatcher/test/trace-dispatcher-test.hs +++ b/trace-dispatcher/test/trace-dispatcher-test.hs @@ -14,8 +14,12 @@ main = defaultMain tests tests :: TestTree tests = localOption (QuickCheckTests 10) $ testGroup "trace-dispatcher" - [ testProperty "not-filtered" $ - runScriptSimple 1.0 oracleFiltering - , testProperty "not-filtered multithreaded" $ - runScriptMultithreaded 1.0 oracleFiltering + [ testProperty "single-threaded send tests" $ + runScriptSimple 1.0 oracleMessages + , testProperty "multi-threaded send tests" $ + runScriptMultithreaded 1.0 oracleMessages + -- , testProperty "multi-threaded send tests with reconfiguration" $ + -- runScriptMultithreadedWithReconfig 1.0 oracleMessages + , testProperty "reconfiguration stress test" $ + runScriptMultithreadedWithConstantReconfig 1.0 (\ _ _ -> property True) ] From 78f4ab5ecde18e7d77e713ac38b583100cf9e632 Mon Sep 17 00:00:00 2001 From: Denis Shevchenko Date: Fri, 10 Sep 2021 18:24:08 +0300 Subject: [PATCH 06/12] trace-dispatcher: update the forwarder integration --- .../src/Cardano/Logging/Tracer/Forward.hs | 107 +++++++++--------- 1 file changed, 52 insertions(+), 55 deletions(-) diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs index 95e2d1fa5b4..33bf76efb34 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs @@ -16,10 +16,7 @@ module Cardano.Logging.Tracer.Forward import Codec.CBOR.Term (Term) import Codec.Serialise (Serialise (..)) import Control.Concurrent.Async (race_, wait, withAsync) -import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, - writeTBQueue) import Control.Monad.IO.Class -import Control.Monad.STM (atomically) import GHC.Generics (Generic) import qualified Control.Tracer as T @@ -58,7 +55,7 @@ import System.Metrics.Network.Forwarder (forwardEKGMetricsResp) import qualified Trace.Forward.Configuration as TF import Trace.Forward.Network.Forwarder (forwardTraceObjectsResp) import Trace.Forward.Protocol.Type (NodeInfo (..)) -import Trace.Forward.Utils (runActionInLoop) +import Trace.Forward.Utils import Cardano.Logging.DocuGenerator import Cardano.Logging.Types @@ -80,52 +77,34 @@ instance ShowProxy TraceObject --------------------------------------------------------------------------- --- newtype ForwardTracerState = ForwardTracerState { --- ftQueue :: TBQueue TraceObject --- } - forwardTracer :: forall m. (MonadIO m) => IOManager -> TraceConfig -> NodeInfo -> m (Trace m FormattedMessage) forwardTracer iomgr config nodeInfo = liftIO $ do - tbQueue <- newTBQueueIO (fromIntegral (tcForwarderQueueSize config)) - store <- EKG.newStore - EKG.registerGcMetrics store - launchForwarders iomgr (tcForwarder config) nodeInfo tbQueue store --- stateRef <- liftIO $ newIORef (ForwardTracerState tbQueue) - pure $ Trace $ T.arrow $ T.emit $ uncurry3 (output tbQueue) - where - output :: - TBQueue TraceObject - -> LoggingContext - -> Maybe TraceControl - -> FormattedMessage - -> m () - output tbQueue LoggingContext {} Nothing (FormattedForwarder lo) = liftIO $ do - atomically $ writeTBQueue tbQueue lo - output _tbQueue LoggingContext {} (Just Reset) _msg = liftIO $ do - pure () - output _tbQueue lk (Just c@Document {}) (FormattedForwarder lo) = do - docIt Forwarder (FormattedHuman False "") (lk, Just c, lo) - output _tbQueue LoggingContext {} _ _a = pure () - -launchForwarders - :: IOManager - -> RemoteAddr - -> NodeInfo - -> TBQueue TraceObject - -> EKG.Store - -> IO () -launchForwarders iomgr ep@(LocalSocket p) nodeInfo tbQueue store = flip - withAsync - wait - $ runActionInLoop - (launchForwardersViaLocalSocket iomgr ep (ekgConfig, tfConfig) tbQueue store) - (TF.LocalPipe p) - 1 + forwardSink <- initForwardSink tfConfig + store <- EKG.newStore + EKG.registerGcMetrics store + launchForwarders iomgr (tcForwarder config) store ekgConfig tfConfig forwardSink + pure $ Trace $ T.arrow $ T.emit $ uncurry3 (output forwardSink) where + output :: + ForwardSink TraceObject + -> LoggingContext + -> Maybe TraceControl + -> FormattedMessage + -> m () + output sink LoggingContext {} Nothing (FormattedForwarder lo) = liftIO $ + writeToSink sink lo + output _sink LoggingContext {} (Just Reset) _msg = liftIO $ do + pure () + output _sink lk (Just c@Document {}) (FormattedForwarder lo) = do + docIt Forwarder (FormattedHuman False "") (lk, Just c, lo) + output _sink LoggingContext {} _ _a = pure () + + LocalSocket p = tcForwarder config + ekgConfig :: EKGF.ForwarderConfiguration ekgConfig = EKGF.ForwarderConfiguration @@ -138,22 +117,40 @@ launchForwarders iomgr ep@(LocalSocket p) nodeInfo tbQueue store = flip tfConfig :: TF.ForwarderConfiguration TraceObject tfConfig = TF.ForwarderConfiguration - { TF.forwarderTracer = contramap show stdoutTracer - , TF.acceptorEndpoint = TF.LocalPipe p - , TF.getNodeInfo = pure nodeInfo + { TF.forwarderTracer = contramap show stdoutTracer + , TF.acceptorEndpoint = TF.LocalPipe p + , TF.getNodeInfo = pure nodeInfo + , TF.disconnectedQueueSize = 200000 + , TF.connectedQueueSize = 2000 } +launchForwarders + :: IOManager + -> RemoteAddr + -> EKG.Store + -> EKGF.ForwarderConfiguration + -> TF.ForwarderConfiguration TraceObject + -> ForwardSink TraceObject + -> IO () +launchForwarders iomgr ep@(LocalSocket p) store ekgConfig tfConfig sink = flip + withAsync + wait + $ runActionInLoop + (launchForwardersViaLocalSocket iomgr ep (ekgConfig, tfConfig) sink store) + (TF.LocalPipe p) + 1 + launchForwardersViaLocalSocket :: IOManager -> RemoteAddr -> (EKGF.ForwarderConfiguration, TF.ForwarderConfiguration TraceObject) - -> TBQueue TraceObject + -> ForwardSink TraceObject -> EKG.Store -> IO () -launchForwardersViaLocalSocket iomgr (LocalSocket localSock) configs tbQueue store = do - let snocket = localSnocket iomgr localSock - address = localAddressFromPath localSock - doListenToAcceptor snocket address noTimeLimitsHandshake configs tbQueue store +launchForwardersViaLocalSocket iomgr (LocalSocket p) configs sink store = do + let snocket = localSnocket iomgr + address = localAddressFromPath p + doListenToAcceptor snocket address noTimeLimitsHandshake configs sink store doListenToAcceptor :: Ord addr @@ -161,10 +158,10 @@ doListenToAcceptor -> addr -> ProtocolTimeLimits (Handshake UnversionedProtocol Term) -> (EKGF.ForwarderConfiguration, TF.ForwarderConfiguration TraceObject) - -> TBQueue TraceObject + -> ForwardSink TraceObject -> EKG.Store -> IO () -doListenToAcceptor snocket address timeLimits (ekgConfig, tfConfig) tbQueue store = do +doListenToAcceptor snocket address timeLimits (ekgConfig, tfConfig) sink store = do networkState <- newNetworkMutableState race_ (cleanNetworkMutableState networkState) $ withServerNode @@ -181,8 +178,8 @@ doListenToAcceptor snocket address timeLimits (ekgConfig, tfConfig) tbQueue stor UnversionedProtocol UnversionedProtocolData (SomeResponderApplication $ - forwarderApp [ (forwardEKGMetricsResp ekgConfig store, 1) - , (forwardTraceObjectsResp tfConfig tbQueue, 2) + forwarderApp [ (forwardEKGMetricsResp ekgConfig store, 1) + , (forwardTraceObjectsResp tfConfig sink, 2) ] ) ) From 8335a65643fa001529c91a7d79b0a5bcd59360a8 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Fri, 17 Sep 2021 13:11:34 +0200 Subject: [PATCH 07/12] trace-resources: new package --- .../Resources => cbits}/os-support-darwin.c | 0 .../Resources => cbits}/os-support-win.c | 6 ++-- .../Resources => include}/os-support-darwin.h | 0 .../Resources => include}/os-support-win.h | 0 .../src/Cardano/Logging/Resources/Darwin.hsc | 13 +++----- .../src/Cardano/Logging/Resources/Types.hs | 32 +++++++++---------- .../src/Cardano/Logging/Resources/Windows.hsc | 13 +++----- trace-resources/trace-resources.cabal | 12 +++---- 8 files changed, 36 insertions(+), 40 deletions(-) rename trace-resources/{src/Cardano/Logging/Resources => cbits}/os-support-darwin.c (100%) rename trace-resources/{src/Cardano/Logging/Resources => cbits}/os-support-win.c (97%) rename trace-resources/{src/Cardano/Logging/Resources => include}/os-support-darwin.h (100%) rename trace-resources/{src/Cardano/Logging/Resources => include}/os-support-win.h (100%) diff --git a/trace-resources/src/Cardano/Logging/Resources/os-support-darwin.c b/trace-resources/cbits/os-support-darwin.c similarity index 100% rename from trace-resources/src/Cardano/Logging/Resources/os-support-darwin.c rename to trace-resources/cbits/os-support-darwin.c diff --git a/trace-resources/src/Cardano/Logging/Resources/os-support-win.c b/trace-resources/cbits/os-support-win.c similarity index 97% rename from trace-resources/src/Cardano/Logging/Resources/os-support-win.c rename to trace-resources/cbits/os-support-win.c index 31dbac194fb..afba1b13990 100644 --- a/trace-resources/src/Cardano/Logging/Resources/os-support-win.c +++ b/trace-resources/cbits/os-support-win.c @@ -14,7 +14,10 @@ int c_get_process_memory_info (PROCESS_MEMORY_COUNTERS *counters, DWORD pid) { if (NULL == hProc) { return -2; } BOOL result = GetProcessMemoryInfo(hProc, counters, sizeof(PROCESS_MEMORY_COUNTERS)); CloseHandle(hProc); - return result; + if (result == 1) + return 0; + else + return -1; } @@ -91,4 +94,3 @@ int c_get_win_bits (DWORD pid) { } return 64; } - diff --git a/trace-resources/src/Cardano/Logging/Resources/os-support-darwin.h b/trace-resources/include/os-support-darwin.h similarity index 100% rename from trace-resources/src/Cardano/Logging/Resources/os-support-darwin.h rename to trace-resources/include/os-support-darwin.h diff --git a/trace-resources/src/Cardano/Logging/Resources/os-support-win.h b/trace-resources/include/os-support-win.h similarity index 100% rename from trace-resources/src/Cardano/Logging/Resources/os-support-win.h rename to trace-resources/include/os-support-win.h diff --git a/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc b/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc index 4506dfc7109..db5eb16e8c3 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc +++ b/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc @@ -10,6 +10,7 @@ module Cardano.Logging.Resources.Darwin import Data.Word (Word64) import Foreign.C.Types import Foreign.Marshal.Alloc +import Foreign.Marshal.Error import Foreign.Ptr import Foreign.Storable import qualified GHC.Stats as GhcStats @@ -76,14 +77,10 @@ foreign import ccall unsafe c_get_process_memory_info :: Ptr MachTaskBasicInfo - getMemoryInfo :: ProcessID -> IO MachTaskBasicInfo getMemoryInfo pid = - allocaBytes 128 $ \ptr -> do - res <- c_get_process_memory_info ptr (fromIntegral pid) - if res <= 0 - then do - putStrLn $ "c_get_process_memory_info: failure returned: " ++ (show res) - return $ MachTaskBasicInfo 0 0 0 (TIME_VALUE_T 0 0) (TIME_VALUE_T 0 0) 0 0 - else - peek ptr + allocaBytes 128 $ \ptr -> do + throwIfNeg_ (\res -> "c_get_process_memory_info: failure returned: " ++ show (pred res)) + (succ <$> c_get_process_memory_info ptr (fromIntegral pid)) + peek ptr readRessoureStatsInternal :: IO (Maybe ResourceStats) readRessoureStatsInternal = getProcessID >>= \pid -> do diff --git a/trace-resources/src/Cardano/Logging/Resources/Types.hs b/trace-resources/src/Cardano/Logging/Resources/Types.hs index 888335664ad..aac05869d45 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Types.hs +++ b/trace-resources/src/Cardano/Logging/Resources/Types.hs @@ -32,14 +32,14 @@ docResourceStats :: Documented ResourceStats docResourceStats = Documented [ DocMsg (ResourceStats 1 1 1 1 1 1 1 1 1 1) - [(["Stat","Cputicks"], "Reports the CPU ticks, sice the process was started") - ,(["Mem","Resident"], "TODO JNF") - ,(["RTS","GcLiveBytes"],"TODO JNF") - ,(["RTS","GcMajorNum"],"TODO JNF") - ,(["RTS","GcMinorNum"],"TODO JNF") - ,(["RTS","Gcticks"],"TODO JNF") - ,(["RTS","Mutticks"],"TODO JNF") - ,(["RTS","Threads"],"TODO JNF") + [("Stat.Cputicks", "Reports the CPU ticks, sice the process was started") + ,("Mem.Resident", "TODO JNF") + ,("RTS.GcLiveBytes", "TODO JNF") + ,("RTS.GcMajorNum", "TODO JNF") + ,("RTS.GcMinorNum", "TODO JNF") + ,("RTS.Gcticks", "TODO JNF") + ,("RTS.Mutticks", "TODO JNF") + ,("RTS.Threads","TODO JNF") ] "TODO JNF" ] @@ -68,12 +68,12 @@ instance LogFormatting ResourceStats where ] asMetrics rs = - [ IntM ["Stat","Cputicks"] (fromIntegral $ rCentiCpu rs) - , IntM ["Mem","Resident"] (fromIntegral $ rRSS rs) - , IntM ["RTS","GcLiveBytes"] (fromIntegral $ rLive rs) - , IntM ["RTS","GcMajorNum"] (fromIntegral $ rGcsMajor rs) - , IntM ["RTS","GcMinorNum"] (fromIntegral $ rGcsMinor rs) - , IntM ["RTS","Gcticks"] (fromIntegral $ rCentiGC rs) - , IntM ["RTS","Mutticks"] (fromIntegral $ rCentiMut rs) - , IntM ["Stat","Threads"] (fromIntegral $ rThreads rs) + [ IntM "Stat.Cputicks" (fromIntegral $ rCentiCpu rs) + , IntM "Mem.Resident" (fromIntegral $ rRSS rs) + , IntM "RTS.GcLiveBytes" (fromIntegral $ rLive rs) + , IntM "RTS.GcMajorNum" (fromIntegral $ rGcsMajor rs) + , IntM "RTS.GcMinorNum" (fromIntegral $ rGcsMinor rs) + , IntM "RTS.Gcticks" (fromIntegral $ rCentiGC rs) + , IntM "RTS.Mutticks" (fromIntegral $ rCentiMut rs) + , IntM "Stat.Threads" (fromIntegral $ rThreads rs) ] diff --git a/trace-resources/src/Cardano/Logging/Resources/Windows.hsc b/trace-resources/src/Cardano/Logging/Resources/Windows.hsc index 2f065e73e0f..f10a11a8d50 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Windows.hsc +++ b/trace-resources/src/Cardano/Logging/Resources/Windows.hsc @@ -11,6 +11,7 @@ module Cardano.Logging.Resources.Windows import Data.Word (Word64) import Foreign.C.Types import Foreign.Marshal.Alloc +import Foreign.Marshal.Error import Foreign.Ptr import Foreign.Storable import qualified GHC.Stats as GhcStats @@ -131,14 +132,10 @@ foreign import ccall unsafe c_get_proc_cpu_times :: Ptr CpuTimes -> CInt -> IO C getMemoryInfo :: ProcessId -> IO ProcessMemoryCounters getMemoryInfo pid = - allocaBytes 128 $ \ptr -> do - res <- c_get_process_memory_info ptr (fromIntegral pid) - if res <= 0 - then do - putStrLn $ "c_get_process_memory_info: failure returned: " ++ (show res) - return $ ProcessMemoryCounters 0 0 0 0 0 0 0 0 0 0 - else - peek ptr + allocaBytes 128 $ \ptr -> do + throwIfNeg_ (\res -> "c_get_process_memory_info: failure returned: " ++ show res) + (c_get_process_memory_info ptr (fromIntegral pid)) + peek ptr readRessoureStatsInternal :: IO (Maybe ResourceStats) readRessoureStatsInternal = getCurrentProcessId >>= \pid -> do diff --git a/trace-resources/trace-resources.cabal b/trace-resources/trace-resources.cabal index 01cf350a275..24d5e247fc8 100644 --- a/trace-resources/trace-resources.cabal +++ b/trace-resources/trace-resources.cabal @@ -8,8 +8,8 @@ maintainer: operations@iohk.io copyright: 2021 IOHK extra-source-files: CHANGELOG.md README.md - src/Cardano/Logging/Resources/os-support-darwin.h - src/Cardano/Logging/Resources/os-support-win.h + include/os-support-darwin.h + include/os-support-win.h library hs-source-dirs: src @@ -42,13 +42,13 @@ library exposed-modules: Cardano.Logging.Resources.Linux if os(windows) exposed-modules: Cardano.Logging.Resources.Windows - c-sources: src/Cardano/Logging/Resources/os-support-win.c - include-dirs: src/Cardano/Logging/Resources/ + c-sources: cbits/os-support-win.c + include-dirs: include/ cc-options: -DPSAPI_VERSION=2 if os(darwin) exposed-modules: Cardano.Logging.Resources.Darwin - c-sources: src/Cardano/Logging/Resources/os-support-darwin.c - include-dirs: src/Cardano/Logging/Resources/ + c-sources: cbits/os-support-darwin.c + include-dirs: include/ test-suite trace-resources-test type: exitcode-stdio-1.0 From 9bde79ae78bca4e45a80b540f3a71b94e9534b59 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Mon, 4 Oct 2021 17:17:37 +0300 Subject: [PATCH 08/12] trace-dispatcher: review changes --- trace-dispatcher/doc/trace-dispatcher.md | 24 ++-- .../examples/Examples/Aggregation.hs | 8 +- .../examples/Examples/Configuration.hs | 14 +- trace-dispatcher/examples/Examples/EKG.hs | 2 +- .../examples/Examples/FrequencyLimiting.hs | 38 ++---- .../examples/Examples/TestObjects.hs | 6 +- trace-dispatcher/examples/Examples/Trivial.hs | 8 +- .../src/Cardano/Logging/Configuration.hs | 45 +++--- .../src/Cardano/Logging/DocuGenerator.hs | 37 +++-- .../src/Cardano/Logging/Formatter.hs | 24 ++-- .../src/Cardano/Logging/FrequencyLimiter.hs | 105 +++++++++----- trace-dispatcher/src/Cardano/Logging/Trace.hs | 29 ++-- .../src/Cardano/Logging/Tracer/Composed.hs | 5 +- .../src/Cardano/Logging/Tracer/EKG.hs | 26 ++-- .../src/Cardano/Logging/Tracer/Forward.hs | 30 +--- .../src/Cardano/Logging/Tracer/Standard.hs | 38 ++++-- trace-dispatcher/src/Cardano/Logging/Types.hs | 129 ++++++++++++------ trace-dispatcher/src/Cardano/Logging/Utils.hs | 8 ++ .../test/Cardano/Logging/Test/Config.hs | 24 ++-- .../test/Cardano/Logging/Test/Messages.hs | 2 +- .../test/Cardano/Logging/Test/Tracer.hs | 2 +- .../test/Cardano/Logging/Test/Types.hs | 2 +- trace-dispatcher/trace-dispatcher.cabal | 1 + 23 files changed, 336 insertions(+), 271 deletions(-) create mode 100644 trace-dispatcher/src/Cardano/Logging/Utils.hs diff --git a/trace-dispatcher/doc/trace-dispatcher.md b/trace-dispatcher/doc/trace-dispatcher.md index 1be2fba8274..8f977737f57 100644 --- a/trace-dispatcher/doc/trace-dispatcher.md +++ b/trace-dispatcher/doc/trace-dispatcher.md @@ -378,13 +378,13 @@ If aggregated information from multiple consecutive messages is needed the follo ```haskell -- | Folds the function with state acc over messages a in the trace. foldTraceM :: MonadIO m - => (acc -> a -> acc) + => (acc -> LoggingContext -> Maybe TraceControl -> a -> acc) -> acc -> Trace m (Folding a acc) -> m (Trace m a) foldMTraceM :: forall a acc m . MonadIO m - => (acc -> a -> m acc) + => (acc -> LoggingContext -> Maybe TraceControl -> a -> acc) -> acc -> Trace m (Folding a acc) -> m (Trace m a) @@ -423,17 +423,21 @@ following way, and it will output the Stats: During definition of the __trace dispatcher__, it is sometimes useful to have a number of functions to route them. -To send the message of a trace to different tracers depending on some criteria use the following function: +To send the message of a trace to different tracers depending on some criteria use the following function + +-- | Allows to route to different tracers, based on the message being processed. +-- The second argument must mappend all possible tracers of the first +-- argument to one tracer. This is required for the configuration! ```haskell -routingTrace :: Monad m => (a -> Trace m a) -> Trace m a +routingTrace :: Monad m => (a -> m (Trace m a)) -> Trace m a -> m (Trace m a) let resTrace = routingTrace routingf (tracer1 <> tracer2) where routingf LO1 {} = tracer1 routingf LO2 {} = tracer2 ``` -The second argument must mappend all possible tracers of the first argument to one tracer. This is required for the configuration. We could have construct a more secure interface by having a map of values to tracers, but the ability for full pattern matching outweigh this disadvantage in our view. +The second argument must mappend all tracers used in the routing trace function to one tracer. This is required for the configuration. We could have construct a more secure interface by having a map of values to tracers, but the ability for full pattern matching outweigh this disadvantage in our view. In the following example we send the messages of one trace to two tracers simultaneously: ```haskell @@ -474,15 +478,15 @@ These are the options that can be configured based on a namespace: ```haskell data ConfigOption = -- | Severity level for filtering (default is WarningF) - CoSeverity SeverityF + ConfSeverity SeverityF -- | Detail level of message representation (Default is DNormal) - | CoDetail DetailLevel + | ConfDetail DetailLevel -- | To which backend to pass -- Default is [EKGBackend, Forwarder, Stdout HumanFormatColoured] - | CoBackend [BackendConfig] + | ConfBackend [BackendConfig] -- | Construct a limiter with name (Text) and limiting to the Double, -- which represents frequency in number of messages per second - | CoLimiter Text Double + | ConfLimiter Text Double data BackendConfig = Forwarder @@ -493,7 +497,7 @@ data TraceConfig = TraceConfig { -- | Options specific to a certain namespace tcOptions :: Map.Map Namespace [ConfigOption] -- | Options for trace-forwarder - , tcForwarder :: RemoteAddr + , tcForwarder :: ForwarderAddr , tcForwarderQueueSize :: Int } ``` diff --git a/trace-dispatcher/examples/Examples/Aggregation.hs b/trace-dispatcher/examples/Examples/Aggregation.hs index 3754532deed..8fe0b12fc52 100644 --- a/trace-dispatcher/examples/Examples/Aggregation.hs +++ b/trace-dispatcher/examples/Examples/Aggregation.hs @@ -27,8 +27,8 @@ instance A.ToJSON BaseStats where instance LogFormatting BaseStats where forMachine = mempty asMetrics BaseStats {..} = - [ DoubleM ["measure"] bsMeasure - , DoubleM ["sum"] bsSum] + [ DoubleM "measure" bsMeasure + , DoubleM "sum" bsSum] baseStatsDocumented :: Documented Double baseStatsDocumented = @@ -40,8 +40,8 @@ baseStatsDocumented = emptyStats :: BaseStats emptyStats = BaseStats 0.0 100000000.0 (-100000000.0) 0 0.0 -calculate :: BaseStats -> LoggingContext -> Double -> BaseStats -calculate BaseStats{..} _ val = +calculate :: BaseStats -> LoggingContext -> Maybe TraceControl -> Double -> BaseStats +calculate BaseStats{..} _ _ val = BaseStats val (min bsMin val) diff --git a/trace-dispatcher/examples/Examples/Configuration.hs b/trace-dispatcher/examples/Examples/Configuration.hs index b5ff98f48d9..99fbd482bb3 100644 --- a/trace-dispatcher/examples/Examples/Configuration.hs +++ b/trace-dispatcher/examples/Examples/Configuration.hs @@ -40,10 +40,10 @@ tracers = do config1 :: TraceConfig config1 = TraceConfig { tcOptions = Map.fromList - [ ([], [CoSeverity SilenceF]) - , (["tracer1"], [CoSeverity ErrorF]) - , (["tracer2"], [CoSeverity CriticalF]) - , (["tracer2","bubble"], [CoSeverity InfoF]) + [ ([], [ConfSeverity (SeverityF Nothing)]) + , (["tracer1"], [ConfSeverity (SeverityF (Just Error))]) + , (["tracer2"], [ConfSeverity (SeverityF (Just Critical))]) + , (["tracer2","bubble"], [ConfSeverity (SeverityF (Just Info))]) ] , tcForwarder = LocalSocket "forwarder.log" , tcForwarderQueueSize = 100 @@ -52,9 +52,9 @@ config1 = TraceConfig { config2 :: TraceConfig config2 = TraceConfig { tcOptions = Map.fromList - [ ([], [CoSeverity InfoF]) - , (["tracer2"], [CoSeverity WarningF]) - , (["tracer2","bubble"], [CoSeverity WarningF]) + [ ([], [ConfSeverity (SeverityF (Just Info))]) + , (["tracer2"], [ConfSeverity (SeverityF (Just Warning))]) + , (["tracer2","bubble"], [ConfSeverity (SeverityF (Just Debug))]) ] , tcForwarder = LocalSocket "forwarder.log" , tcForwarderQueueSize = 100 diff --git a/trace-dispatcher/examples/Examples/EKG.hs b/trace-dispatcher/examples/Examples/EKG.hs index 9d7671b75e5..eed73562a11 100644 --- a/trace-dispatcher/examples/Examples/EKG.hs +++ b/trace-dispatcher/examples/Examples/EKG.hs @@ -16,7 +16,7 @@ testEKG :: IO () testEKG = do server <- forkServer "localhost" 8000 tracer <- ekgTracer (Right server) - formattedTracer <- metricsFormatter "cardano" tracer + let formattedTracer = metricsFormatter "cardano" tracer configureTracers emptyTraceConfig countDocumented [formattedTracer] loop (appendName "ekg1" formattedTracer) 1 where diff --git a/trace-dispatcher/examples/Examples/FrequencyLimiting.hs b/trace-dispatcher/examples/Examples/FrequencyLimiting.hs index 32d7f3b2091..d1909c0469d 100644 --- a/trace-dispatcher/examples/Examples/FrequencyLimiting.hs +++ b/trace-dispatcher/examples/Examples/FrequencyLimiting.hs @@ -3,30 +3,10 @@ module Examples.FrequencyLimiting ( ) 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 @@ -36,13 +16,17 @@ repeated t n d = do 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 + t1 <- standardTracer Nothing + tf1 <- humanFormatter True "cardano" t1 + tf2 <- limitFrequency 5 "5 messages per second" + (appendName "tracer1" (contramap Message tf1)) + (appendName "limiter1" (contramap Limit tf1)) + tf3 <- limitFrequency 15 "15 messages per second" + (appendName "tracer2" (contramap Message tf1)) + (appendName "limiter2" (contramap Limit tf1)) + let t = tf2 <> tf3 + configureTracers emptyTraceConfig traceForgeEventDocu [t] + repeated t 1000 10000 -- 100 messages per second repeated t 20 1000000 -- 1 message per second repeated t 300 100000 -- 10 message per second diff --git a/trace-dispatcher/examples/Examples/TestObjects.hs b/trace-dispatcher/examples/Examples/TestObjects.hs index 159f992eb4c..c858ee58a7a 100644 --- a/trace-dispatcher/examples/Examples/TestObjects.hs +++ b/trace-dispatcher/examples/Examples/TestObjects.hs @@ -142,11 +142,11 @@ instance LogFormatting (TraceForgeEvent LogBlock) where ] asMetrics (TraceStartLeadershipCheck slotNo) = - [IntM ["aboutToLeadSlotLast"] (fromIntegral $ unSlotNo slotNo)] + [IntM "aboutToLeadSlotLast" (fromIntegral $ unSlotNo slotNo)] asMetrics (TraceSlotIsImmutable slot _tipPoint _tipBlkNo) = - [IntM ["slotIsImmutable"] (fromIntegral $ unSlotNo slot)] + [IntM "slotIsImmutable" (fromIntegral $ unSlotNo slot)] asMetrics (TraceBlockFromFuture slot _slotNo) = - [IntM ["blockFromFuture"] (fromIntegral $ unSlotNo slot)] + [IntM "blockFromFuture" (fromIntegral $ unSlotNo slot)] traceForgeEventDocu :: Documented (TraceForgeEvent LogBlock) traceForgeEventDocu = Documented diff --git a/trace-dispatcher/examples/Examples/Trivial.hs b/trace-dispatcher/examples/Examples/Trivial.hs index f91d8762997..0d24b951abd 100644 --- a/trace-dispatcher/examples/Examples/Trivial.hs +++ b/trace-dispatcher/examples/Examples/Trivial.hs @@ -16,7 +16,9 @@ test1 = do stdoutTracer' <- standardTracer Nothing simpleTracer <- machineFormatter "cardano" stdoutTracer' configureTracers emptyTraceConfig traceForgeEventDocu [simpleTracer] - let simpleTracer1 = filterTraceBySeverity (Just WarningF) simpleTracer + let simpleTracer1 = filterTraceBySeverity + (Just (SeverityF (Just Warning))) + simpleTracer let simpleTracerC1 = appendName "Outer1" simpleTracer1 let simpleTracerC2 = appendName "Inner1" simpleTracerC1 let simpleTracerC3 = setSeverity Error @@ -33,7 +35,9 @@ test2 = do simpleTracer <- humanFormatter True "cardano" stdoutTracer' configureTracers emptyTraceConfig traceForgeEventDocu [simpleTracer] let simpleTracer1 = withSeverity loSeverity - (filterTraceBySeverity (Just WarningF) simpleTracer) + (filterTraceBySeverity + (Just (SeverityF (Just Warning))) + simpleTracer) let simpleTracerC1 = appendName "Outer1" simpleTracer1 let simpleTracerC2 = appendName "Inner1" simpleTracerC1 let simpleTracerC3 = setPrivacy Confidential $ appendName "Inner2" simpleTracerC1 diff --git a/trace-dispatcher/src/Cardano/Logging/Configuration.hs b/trace-dispatcher/src/Cardano/Logging/Configuration.hs index 9af38c53760..e6a0f236359 100644 --- a/trace-dispatcher/src/Cardano/Logging/Configuration.hs +++ b/trace-dispatcher/src/Cardano/Logging/Configuration.hs @@ -45,9 +45,9 @@ defaultConfig :: TraceConfig defaultConfig = emptyTraceConfig { tcOptions = Map.fromList [([] :: Namespace, - [ CoSeverity InfoF - , CoDetail DNormal - , CoBackend [Stdout HumanFormatColoured] + [ ConfSeverity (SeverityF (Just Info)) + , ConfDetail DNormal + , ConfBackend [Stdout HumanFormatColoured] ]) ] } @@ -101,13 +101,11 @@ withNamespaceConfig name extract withConfig tr = do Left (_cmap, Nothing) -> pure () -- This can happen during reconfiguration, so we don't throw an error any more mkTrace ref (lc, Just Reset, a) = do --- trace ("mkTrace Reset " <> show (lcNamespace lc)) $ pure () liftIO $ writeIORef ref (Left (Map.empty, Nothing)) tt <- withConfig Nothing tr T.traceWith (unpackTrace tt) (lc, Just Reset, a) mkTrace ref (lc, Just (Config c), m) = do --- trace ("mkTrace Config " <> show (lcNamespace lc)) $ pure () ! val <- extract c (lcNamespace lc) eitherConf <- liftIO $ readIORef ref case eitherConf of @@ -136,12 +134,8 @@ withNamespaceConfig name extract withConfig tr = do case eitherConf of Left (cmap, Nothing) -> case nub (Map.elems cmap) of - [] -> -- trace ("mkTrace Optimize empty " <> show (lcNamespace lc)) $ - -- This will never be called!? - pure () + [] -> pure () [val] -> do - -- trace ("mkTrace Optimize one " <> show (lcNamespace lc) - -- <> " val " <> show val) $ pure () liftIO $ writeIORef ref $ Right val Trace tt <- withConfig (Just val) tr T.traceWith tt (lc, Just Optimize, m) @@ -155,9 +149,6 @@ withNamespaceConfig name extract withConfig tr = do (Map.assocs decidingDict) newmap = Map.filter (/= mostCommon) cmap in do - -- trace ("mkTrace Optimize map " <> show (lcNamespace lc) - -- <> " val " <> show mostCommon - -- <> " map " <> show newmap) $ pure () liftIO $ writeIORef ref (Left (newmap, Just mostCommon)) Trace tt <- withConfig Nothing tr T.traceWith tt (lc, Just Optimize, m) @@ -296,11 +287,11 @@ withLimitersFromConfig tr trl = do -- | If no severity can be found in the config, it is set to Warning getSeverity :: TraceConfig -> Namespace -> SeverityF getSeverity config ns = - fromMaybe WarningF (getOption severitySelector config ns) + fromMaybe (SeverityF (Just Warning)) (getOption severitySelector config ns) where severitySelector :: ConfigOption -> Maybe SeverityF - severitySelector (CoSeverity s) = Just s - severitySelector _ = Nothing + severitySelector (ConfSeverity s) = Just s + severitySelector _ = Nothing getSeverity' :: Applicative m => TraceConfig -> Namespace -> m SeverityF getSeverity' config ns = pure $ getSeverity config ns @@ -311,8 +302,8 @@ getDetails config ns = fromMaybe DNormal (getOption detailSelector config ns) where detailSelector :: ConfigOption -> Maybe DetailLevel - detailSelector (CoDetail d) = Just d - detailSelector _ = Nothing + detailSelector (ConfDetail d) = Just d + detailSelector _ = Nothing getDetails' :: Applicative m => TraceConfig -> Namespace -> m DetailLevel getDetails' config ns = pure $ getDetails config ns @@ -325,8 +316,8 @@ getBackends config ns = (getOption backendSelector config ns) where backendSelector :: ConfigOption -> Maybe [BackendConfig] - backendSelector (CoBackend s) = Just s - backendSelector _ = Nothing + backendSelector (ConfBackend s) = Just s + backendSelector _ = Nothing getBackends' :: Applicative m => TraceConfig -> Namespace -> m [BackendConfig] getBackends' config ns = pure $ getBackends config ns @@ -336,8 +327,8 @@ getLimiterSpec :: TraceConfig -> Namespace -> Maybe (Text, Double) getLimiterSpec = getOption limiterSelector where limiterSelector :: ConfigOption -> Maybe (Text, Double) - limiterSelector (CoLimiter n f) = Just (n, f) - limiterSelector _ = Nothing + limiterSelector (ConfLimiter n f) = Just (n, f) + limiterSelector _ = Nothing -- | Searches in the config to find an option @@ -375,25 +366,25 @@ parseRepresentation bs = transform (decodeEither' bs) let tc' = foldl' (\ tci (TraceOptionSeverity ns severity') -> let ns' = split (=='.') ns ns'' = if ns' == [""] then [] else ns' - in Map.insertWith (++) ns'' [CoSeverity severity'] tci) + in Map.insertWith (++) ns'' [ConfSeverity severity'] tci) tc (traceOptionSeverity cr) tc'' = foldl' (\ tci (TraceOptionDetail ns detail') -> let ns' = split (=='.') ns ns'' = if ns' == [""] then [] else ns' - in Map.insertWith (++) ns'' [CoDetail detail'] tci) + in Map.insertWith (++) ns'' [ConfDetail detail'] tci) tc' (traceOptionDetail cr) tc''' = foldl' (\ tci (TraceOptionBackend ns backend') -> let ns' = split (=='.') ns ns'' = if ns' == [""] then [] else ns' - in Map.insertWith (++) ns'' [CoBackend backend'] tci) + in Map.insertWith (++) ns'' [ConfBackend backend'] tci) tc'' (traceOptionBackend cr) tc'''' = foldl' (\ tci (TraceOptionLimiter ns name frequ) -> let ns' = split (=='.') ns ns'' = if ns' == [""] then [] else ns' - in Map.insertWith (++) ns'' [CoLimiter name frequ] tci) + in Map.insertWith (++) ns'' [ConfLimiter name frequ] tci) tc''' (traceOptionLimiter cr) in TraceConfig @@ -470,7 +461,7 @@ data ConfigRepresentation = ConfigRepresentation { , traceOptionDetail :: [TraceOptionDetail] , traceOptionBackend :: [TraceOptionBackend] , traceOptionLimiter :: [TraceOptionLimiter] - , traceOptionForwarder :: RemoteAddr + , traceOptionForwarder :: ForwarderAddr , traceOptionForwardQueueSize :: Int } deriving (Eq, Ord, Show) diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs index 9311843b08e..be2844703fa 100644 --- a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs +++ b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs @@ -191,16 +191,14 @@ documentMarkdown (Documented documented) tracers = do (intersperse (singleton '\n') (map (\case - (IntM ns i) -> + (IntM name i) -> fromText "Integer metrics:\n" - <> asCode (mconcat $ intersperse (singleton '.') - (map fromText ns)) + <> asCode (fromText name) <> singleton ' ' <> fromString (show i) - (DoubleM ns i) -> + (DoubleM name i) -> fromText "Double metrics:\n" - <> asCode (mconcat $ intersperse (singleton '.') - (map fromText ns)) + <> asCode (fromText name) <> singleton ' ' <> fromString (show i)) l)) @@ -254,10 +252,11 @@ documentMarkdown (Documented documented) tracers = do filteredBuilder l r = fromText "Filtered: " <> case (l, r) of - ([lh], [rh]) -> + ([SeverityF (Just lh)], [rh]) -> if fromEnum rh >= fromEnum lh then (asCode . fromString) "Visible" else (asCode . fromString) "Invisible" + ([SeverityF Nothing], [_rh]) -> "Invisible" _ -> mempty <> fromText " ~ " <> mconcat (intersperse (fromText ", ") @@ -281,7 +280,7 @@ documentMarkdown (Documented documented) tracers = do fMetrics _ = False metricsBuilder :: - Map.Map Namespace Text + Map.Map Text Text -> [(BackendConfig, FormattedMessage)] -> Builder metricsBuilder _ [] = mempty @@ -289,36 +288,36 @@ documentMarkdown (Documented documented) tracers = do mconcat $ map (metricsFormatToText metricsDoc) l metricsFormatToText :: - Map.Map Namespace Text + Map.Map Text Text -> (BackendConfig, FormattedMessage) -> Builder metricsFormatToText metricsDoc (_be, FormattedMetrics l) = mconcat (intersperse (fromText ",\n") (map (metricFormatToText metricsDoc) l)) - metricFormatToText :: Map.Map Namespace Text -> Metric -> Builder - metricFormatToText metricsDoc (IntM ns _) = + metricFormatToText :: Map.Map Text Text -> Metric -> Builder + metricFormatToText metricsDoc (IntM name _) = fromText "#### _Int metric:_ " - <> mconcat (intersperse (singleton '.') (map fromText ns)) + <> fromText name <> fromText "\n" - <> case Map.lookup ns metricsDoc of + <> case Map.lookup name metricsDoc of Just "" -> mempty Just text -> betweenLines (fromText text) Nothing -> mempty - metricFormatToText metricsDoc (DoubleM ns _) = + metricFormatToText metricsDoc (DoubleM name _) = fromText "#### _Double metric:_ " - <> mconcat (intersperse (singleton '.') (map fromText ns)) + <> fromText name <> fromText "\n" - <> case Map.lookup ns metricsDoc of + <> case Map.lookup name metricsDoc of Just "" -> mempty Just text -> betweenLines (fromText text) Nothing -> mempty - metricFormatToText metricsDoc (CounterM ns _) = + metricFormatToText metricsDoc (CounterM name _) = fromText "#### _Counter metric:_ " - <> mconcat (intersperse (singleton '.') (map fromText ns)) + <> fromText name <> fromText "\n" - <> case Map.lookup ns metricsDoc of + <> case Map.lookup name metricsDoc of Just "" -> mempty Just text -> betweenLines (fromText text) Nothing -> mempty diff --git a/trace-dispatcher/src/Cardano/Logging/Formatter.hs b/trace-dispatcher/src/Cardano/Logging/Formatter.hs index 8fbf796aace..0b52b5f7400 100644 --- a/trace-dispatcher/src/Cardano/Logging/Formatter.hs +++ b/trace-dispatcher/src/Cardano/Logging/Formatter.hs @@ -38,23 +38,23 @@ metricsFormatter :: forall a m . (LogFormatting a, MonadIO m) => Text -> Trace m FormattedMessage - -> m (Trace m a) -metricsFormatter application (Trace tr) = do + -> Trace m a +metricsFormatter application (Trace tr) = let trr = mkTracer - pure $ Trace (T.arrow trr) + in Trace (T.arrow trr) where mkTracer = T.emit $ \ case (lc, Nothing, v) -> let metrics = asMetrics v in T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} - , Nothing - , FormattedMetrics metrics) + , Nothing + , FormattedMetrics metrics) (lc, Just ctrl, v) -> let metrics = asMetrics v in T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} - , Just ctrl - , FormattedMetrics metrics) + , Just ctrl + , FormattedMetrics metrics) -- | Format this trace as TraceObject for the trace forwarder forwardFormatter @@ -191,13 +191,13 @@ machineFormatter application (Trace tr) = do let detailLevel = fromMaybe DNormal (lcDetails lc) obj <- liftIO $ formatContextMachine hn application lc (forMachine detailLevel v) T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} - , Nothing - , FormattedMachine (decodeUtf8 (BS.toStrict - (AE.encodingToLazyByteString obj)))) + , Nothing + , FormattedMachine (decodeUtf8 (BS.toStrict + (AE.encodingToLazyByteString obj)))) (lc, Just c, _v) -> do T.traceWith tr (lc { lcNamespace = application : lcNamespace lc} - , Just c - , FormattedMachine "") + , Just c + , FormattedMachine "") formatContextMachine :: String diff --git a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs index 2ef77957e24..b8b7344c3e9 100644 --- a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs +++ b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs @@ -18,6 +18,14 @@ import GHC.Generics import Cardano.Logging.Trace import Cardano.Logging.Types +-- | Treshold for starting and stopping of the limiter +budgetLimit :: Double +budgetLimit = 30.0 + +-- | After how many seconds a reminder message is send +reminderPeriod :: Double +reminderPeriod = 10.0 + data LimiterSpec = LimiterSpec { lsNs :: [Text] , lsName :: Text @@ -58,7 +66,7 @@ instance LogFormatting LimitingMessage where ] asMetrics (StartLimiting _txt) = [] asMetrics (StopLimiting txt num) = [IntM - ["SuppressedMessages " <> txt] + ("SuppressedMessages " <> txt) (fromIntegral num)] asMetrics (RememberLimiting _txt _num) = [] @@ -68,27 +76,41 @@ data FrequencyRec a = FrequencyRec { , frLastRem :: Double -- ^ The time since the last limiting remainder was send , frBudget :: Double -- ^ A budget which is used to decide when to start limiting -- and stop limiting. When messages arrive in shorter frquency then - -- by the given thresholdFrequency budget is spend, and if they - -- arrive in a longer period budget is earned. - -- A value between 1.0 and -1.0. If -1.0 is reached start limiting, - -- and if 1.0 is reached stop limiting. + -- by the given thresholdFrequency budget is earned, and if they + -- arrive in a longer period budget is spend. , frActive :: Maybe (Int, Double) -- ^ Just is active and carries the number -- of suppressed messages and the time of last send message } deriving (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 percentage --- on the vtracer until the frequency falls under the treshold. +-- messages with the given frequency on the 'vtracer' until the +-- frequency falls under the treshold long enough.(see below) +-- +-- Before this the 'ltracer' gets a 'StartLimiting' message. +-- Inbetween 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 treshold. This value gets then normalized, so that +-- (0.0-10.0) means message arrive quicker then treshold and (0.0..-10.0) +-- means that messages arrive slower then treshold. + --- Before this the ltracer gets a StartLimiting message with the --- current percentage given as a floating point number between 1.0 and 0.0. --- Inbetween you can receive ContinueLimiting messages on the ltracer, --- with the current percentage. --- Finally it sends a StopLimiting message on the ltracer and traces all --- messages on the vtracer again. limitFrequency :: forall a m . (MonadIO m, MonadUnliftIO m) => Double -- messages per second @@ -98,32 +120,45 @@ limitFrequency -> m (Trace m a) -- the original trace limitFrequency thresholdFrequency limiterName vtracer ltracer = do timeNow <- systemTimeToSeconds <$> liftIO getSystemTime --- trace ("limitFrequency called " <> unpack limiterName) $ pure () foldMTraceM (checkLimiting (1.0 / thresholdFrequency)) (FrequencyRec Nothing timeNow 0.0 0.0 Nothing) (Trace $ T.contramap unfoldTrace (unpackTrace (filterTraceMaybe vtracer))) where - checkLimiting :: Double -> FrequencyRec a -> LoggingContext -> a -> m (FrequencyRec a) - checkLimiting thresholdPeriod fs@FrequencyRec {..} lc message = do - -- trace ("Limiter " <> unpack limiterName <> " receives " <> show (lcNamespace lc)) - -- $ pure () + checkLimiting :: + Double + -> FrequencyRec a + -> LoggingContext + -> Maybe TraceControl + -> a + -> m (FrequencyRec a) + checkLimiting _thresholdPeriod fs@FrequencyRec{} lc (Just c) message = do + T.traceWith + (unpackTrace ltracer) + (lc, Just c, StartLimiting "configure") + pure fs {frMessage = Just message} + checkLimiting thresholdPeriod fs@FrequencyRec{..} lc Nothing message = do timeNow <- liftIO $ systemTimeToSeconds <$> getSystemTime let elapsedTime = timeNow - frLastTime - let rawSpendReward = elapsedTime - thresholdPeriod - -- negative if shorter, positive if longer - let normaSpendReward = rawSpendReward * thresholdFrequency -- TODO not really normalized - let spendReward = min 0.5 (max (-0.5) normaSpendReward) - let newBudget = min 1.0 (max (-1.0) (spendReward + frBudget)) - -- trace ("elapsedTime " ++ show elapsedTime - -- ++ " thresholdPeriod " ++ show thresholdPeriod - -- ++ " rawSpendReward " ++ show rawSpendReward - -- ++ " normaSpendReward " ++ show normaSpendReward - -- ++ " spendReward " ++ show spendReward - -- ++ " newBudget " ++ show newBudget $ + -- How many times too quick does the message arrive (thresholdPeriod / elapsedTime) + -- A value less then 1.0 means the message is + -- arriving slower then treshold + let rawSpendReward = if elapsedTime == 0.0 + then 10.0 + else thresholdPeriod / elapsedTime + let spendReward = if rawSpendReward < 1.0 && rawSpendReward > 0.0 + then - ((1.0 / rawSpendReward) - 1.0) + else rawSpendReward - 1.0 + -- Normalize so that (0.0-10.0) means message + -- arrive quicker then treshold + -- and (0.0..-10.0) means that messages arrive + -- slower then treshold + let normaSpendReward = min 10.0 (max (-10.0) spendReward) + let newBudget = min budgetLimit (max (-budgetLimit) + (normaSpendReward + frBudget)) case frActive of - Nothing -> -- not active - if spendReward + frBudget <= -1.0 + Nothing -> -- limiter not active + if normaSpendReward + frBudget >= budgetLimit then do -- start limiting traceWith (setSeverity Info (withLoggingContext lc ltracer)) @@ -141,7 +176,7 @@ limitFrequency thresholdFrequency limiterName vtracer ltracer = do , frBudget = newBudget } Just (nSuppressed, lastTimeSend) -> -- is active - if spendReward + frBudget >= 1.0 + if normaSpendReward + frBudget <= (- budgetLimit) then do -- stop limiting traceWith (setSeverity Info (withLoggingContext lc ltracer)) @@ -155,7 +190,7 @@ limitFrequency thresholdFrequency limiterName vtracer ltracer = do let lastPeriod = timeNow - lastTimeSend lastReminder = timeNow - frLastRem in do - newFrLastRem <- if lastReminder > 15.0 -- send out every 15 seconds + newFrLastRem <- if lastReminder > reminderPeriod then do traceWith (setSeverity Info @@ -163,8 +198,6 @@ limitFrequency thresholdFrequency limiterName vtracer ltracer = do (RememberLimiting limiterName nSuppressed) pure timeNow else pure frLastRem - -- trace ("lastPeriod " ++ show lastPeriod - -- ++ " thresholdPeriod " ++ show thresholdPeriod) $ if lastPeriod > thresholdPeriod then -- send pure fs { frMessage = Just message diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs index 63c27161ceb..c9b9e85042b 100644 --- a/trace-dispatcher/src/Cardano/Logging/Trace.hs +++ b/trace-dispatcher/src/Cardano/Logging/Trace.hs @@ -68,7 +68,7 @@ filterTraceMaybe :: Monad m => filterTraceMaybe (Trace tr) = Trace $ T.squelchUnless (\case - (_lc, _mbC, Just _a) -> True + (_lc, _mbC, Just _) -> True (_lc, _mbC, Nothing) -> False) (T.contramap (\case @@ -86,9 +86,11 @@ filterTraceBySeverity (Just minSeverity) = filterTrace $ \case (_lc, Just _, _a) -> True - (lc, _, _e) -> + (lc, _, _e) -> case lcSeverity lc of - Just s -> fromEnum s >= fromEnum minSeverity + Just s -> case minSeverity of + SeverityF (Just fs) -> s >= fs + SeverityF Nothing -> False Nothing -> True filterTraceBySeverity Nothing = id @@ -202,7 +204,7 @@ withDetails fs (Trace tr) = Trace $ -- Uses an MVar to store the state foldTraceM :: forall a acc m . (MonadUnliftIO m) - => (acc -> LoggingContext -> a -> acc) + => (acc -> LoggingContext -> Maybe TraceControl -> a -> acc) -> acc -> Trace m (Folding a acc) -> m (Trace m a) @@ -215,17 +217,19 @@ foldTraceM cata initial (Trace tr) = do \case (lc, Nothing, v) -> do x' <- modifyMVar ref $ \x -> - let ! accu = cata x lc v - in pure $ join (,) accu + let ! accu = cata x lc Nothing v + in pure (accu,accu) T.traceWith tr (lc, Nothing, Folding x') - (lc, Just control, _v) -> do - T.traceWith tr (lc, Just control, Folding initial) + (lc, Just control, v) -> do + let x' = cata initial lc (Just control) v + T.traceWith tr (lc, Just control, Folding x') + -- | Folds the monadic cata function with acc over a. -- Uses an IORef to store the state foldMTraceM :: forall a acc m . (MonadUnliftIO m) - => (acc -> LoggingContext -> a -> m acc) + => (acc -> LoggingContext -> Maybe TraceControl -> a -> m acc) -> acc -> Trace m (Folding a acc) -> m (Trace m a) @@ -238,11 +242,12 @@ foldMTraceM cata initial (Trace tr) = do \case (lc, Nothing, v) -> do x' <- modifyMVar ref $ \x -> do - ! accu <- cata x lc v + ! accu <- cata x lc Nothing v pure $ join (,) accu T.traceWith tr (lc, Nothing, Folding x') - (lc, Just control, _v) -> do - T.traceWith tr (lc, Just control, Folding initial) + (lc, Just control, v) -> do + x' <- cata initial lc (Just control) v + T.traceWith tr (lc, Just control, Folding x') -- | Allows to route to different tracers, based on the message being processed. -- The second argument must mappend all possible tracers of the first diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs index 40b8e58bda8..d94bfd9e303 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs @@ -3,6 +3,7 @@ module Cardano.Logging.Tracer.Composed ( mkCardanoTracer , mkCardanoTracer' + , MessageOrLimit(..) ) where import Data.Maybe (fromMaybe) @@ -53,7 +54,7 @@ mkCardanoTracer trStdout trForward mbTrEkg name namesFor severityFor privacyFor privacyFor noHook where noHook :: Trace IO evt -> IO (Trace IO evt) - noHook tr = pure tr + noHook = pure -- | Adds the possibility to add special tracers via the hook function mkCardanoTracer' :: forall evt evt1. @@ -98,7 +99,7 @@ mkCardanoTracer' trStdout trForward mbTrEkg name namesFor severityFor privacyFor Nothing -> pure Nothing Just ekgTrace -> if EKGBackend `elem` backends - then fmap Just + then pure $ Just (metricsFormatter "Cardano" ekgTrace) else pure Nothing mbForwardTrace <- if Forwarder `elem` backends diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs index 973e3958b07..23a309242f2 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs @@ -11,9 +11,9 @@ import Cardano.Logging.Types import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Control.Tracer as T -import Data.IORef (newIORef, readIORef, writeIORef) +import Data.IORef (newIORef, readIORef, writeIORef, IORef) import qualified Data.Map.Strict as Map -import Data.Text (intercalate, pack) +import Data.Text (pack, Text) import qualified System.Metrics as Metrics import qualified System.Metrics.Counter as Counter import qualified System.Metrics.Gauge as Gauge @@ -30,6 +30,12 @@ ekgTracer storeOrServer = liftIO $ do pure $ Trace $ T.arrow $ T.emit $ output rgsGauges rgsLabels rgsCounters where + output :: MonadIO m => + IORef (Map.Map Text Gauge.Gauge) + -> IORef (Map.Map Text Label.Label) + -> IORef (Map.Map Text Counter.Counter) + -> (LoggingContext, Maybe TraceControl, FormattedMessage) + -> m () output rgsGauges rgsLabels rgsCounters (LoggingContext{..}, Nothing, FormattedMetrics m) = liftIO $ mapM_ @@ -39,10 +45,16 @@ ekgTracer storeOrServer = liftIO $ do output _ _ _ (LoggingContext{}, Just _c, _v) = pure () + setIt :: + IORef (Map.Map Text Gauge.Gauge) + -> IORef (Map.Map Text Label.Label) + -> IORef (Map.Map Text Counter.Counter) + -> Namespace + -> Metric + -> IO () setIt rgsGauges _rgsLabels _rgsCounters _namespace - (IntM ns theInt) = do + (IntM name theInt) = do rgsMap <- readIORef rgsGauges - let name = intercalate "." ns case Map.lookup name rgsMap of Just gauge -> Gauge.set gauge (fromIntegral theInt) Nothing -> do @@ -53,9 +65,8 @@ ekgTracer storeOrServer = liftIO $ do writeIORef rgsGauges rgsGauges' Gauge.set gauge (fromIntegral theInt) setIt _rgsGauges rgsLabels _rgsCounters _namespace - (DoubleM ns theDouble) = do + (DoubleM name theDouble) = do rgsMap <- readIORef rgsLabels - let name = intercalate "." ns case Map.lookup name rgsMap of Just label -> Label.set label ((pack . show) theDouble) Nothing -> do @@ -66,9 +77,8 @@ ekgTracer storeOrServer = liftIO $ do writeIORef rgsLabels rgsLabels' Label.set label ((pack . show) theDouble) setIt _rgsGauges _rgsLabels rgsCounters _namespace - (CounterM ns mbInt) = do + (CounterM name mbInt) = do rgsMap <- readIORef rgsCounters - let name = intercalate "." ns case Map.lookup name rgsMap of Just counter -> case mbInt of Nothing -> Counter.inc counter diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs index 33bf76efb34..84725943ac1 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs @@ -1,12 +1,9 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Logging.Tracer.Forward ( @@ -14,10 +11,8 @@ module Cardano.Logging.Tracer.Forward ) where import Codec.CBOR.Term (Term) -import Codec.Serialise (Serialise (..)) import Control.Concurrent.Async (race_, wait, withAsync) import Control.Monad.IO.Class -import GHC.Generics (Generic) import qualified Control.Tracer as T import "contra-tracer" Control.Tracer (contramap, stdoutTracer) @@ -47,7 +42,6 @@ import Ouroboros.Network.Socket (AcceptedConnectionsLimit (..), SomeResponderApplication (..), cleanNetworkMutableState, newNetworkMutableState, nullNetworkServerTracers, withServerNode) -import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) import qualified System.Metrics as EKG import qualified System.Metrics.Configuration as EKGF @@ -59,21 +53,7 @@ import Trace.Forward.Utils import Cardano.Logging.DocuGenerator import Cardano.Logging.Types - --- Instances for 'TraceObject' to forward it using 'trace-forward' library. - -deriving instance Generic Privacy -deriving instance Generic SeverityS -deriving instance Generic LoggingContext -deriving instance Generic TraceObject - -instance Serialise DetailLevel -instance Serialise Privacy -instance Serialise SeverityS -instance Serialise LoggingContext -instance Serialise TraceObject - -instance ShowProxy TraceObject +import Cardano.Logging.Utils(uncurry3) --------------------------------------------------------------------------- @@ -126,7 +106,7 @@ forwardTracer iomgr config nodeInfo = liftIO $ do launchForwarders :: IOManager - -> RemoteAddr + -> ForwarderAddr -> EKG.Store -> EKGF.ForwarderConfiguration -> TF.ForwarderConfiguration TraceObject @@ -142,7 +122,7 @@ launchForwarders iomgr ep@(LocalSocket p) store ekgConfig tfConfig sink = flip launchForwardersViaLocalSocket :: IOManager - -> RemoteAddr + -> ForwarderAddr -> (EKGF.ForwarderConfiguration, TF.ForwarderConfiguration TraceObject) -> ForwardSink TraceObject -> EKG.Store @@ -199,7 +179,3 @@ doListenToAcceptor snocket address timeLimits (ekgConfig, tfConfig) sink store = } | (prot, num) <- protocols ] - --- | Converts a curried function to a function on a triple. -uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) -uncurry3 f ~(a,b,c) = f a b c diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs index 3578d85726b..c66596040ed 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs @@ -5,18 +5,19 @@ module Cardano.Logging.Tracer.Standard ( standardTracer ) where -import Control.Concurrent (forkIO) +import Control.Concurrent.Async import Control.Concurrent.Chan.Unagi.Bounded import Control.Monad (forever) import Control.Monad.IO.Class import Data.IORef (IORef, modifyIORef, newIORef, readIORef) import Data.Text (Text) import qualified Data.Text.IO as TIO -import GHC.Conc (ThreadId) +import Data.Void (Void) import System.IO (hFlush, stdout) import Cardano.Logging.DocuGenerator import Cardano.Logging.Types +import Cardano.Logging.Utils (uncurry3) import qualified Control.Tracer as T @@ -26,7 +27,7 @@ data LogTarget = LogStdout | LogFile FilePath -- | The state of a standard tracer data StandardTracerState a = StandardTracerState { - stRunning :: Maybe (InChan Text, OutChan Text, ThreadId) + stRunning :: Maybe (InChan Text, OutChan Text, Async Void) , stTarget :: LogTarget } @@ -61,7 +62,9 @@ standardTracer mbFilePath = do output stateRef LoggingContext {} (Just Reset) _msg = liftIO $ do st <- readIORef stateRef case stRunning st of - Nothing -> initLogging stateRef + Nothing -> case stRunning st of + Just (inChannel, _, _) -> pure () + Nothing -> startWriterThread stateRef Just _ -> pure () output _ lk (Just c@Document {}) (FormattedHuman co msg) = docIt @@ -72,11 +75,22 @@ standardTracer mbFilePath = do docIt (Stdout MachineFormat) (FormattedMachine "") (lk, Just c, msg) output _stateRef LoggingContext {} _ _a = pure () --- TODO: care about reconfiguration -initLogging :: IORef (StandardTracerState a) -> IO () -initLogging stateRef = do - (inChan, outChan) <- newChan 2048 - threadId <- forkIO $ forever $ do +-- | Forks a new thread, which writes the messages either to stdout or a file +startWriterThread :: IORef (StandardTracerState a) -> IO () +startWriterThread stateRef = do + (inChan, outChan) <- newChan 2048 + as <- async (writerThread stateRef outChan) + modifyIORef stateRef (\ st -> + st {stRunning = Just (inChan, outChan, as)}) + + +-- | The new thread, which does the actual write from the queue. +-- runs forever, and never returns +writerThread :: + IORef (StandardTracerState a) + -> OutChan Text + -> IO Void +writerThread stateRef outChan = forever $ do msg <- readChan outChan state <- readIORef stateRef case stTarget state of @@ -86,9 +100,3 @@ initLogging stateRef = do LogStdout -> do TIO.putStrLn msg hFlush stdout - modifyIORef stateRef (\ st -> - st {stRunning = Just (inChan, outChan, threadId)}) - --- | Converts a curried function to a function on a triple. -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 f ~(a,b,c) = f a b c diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs index 0e9d67598ea..4be6900354f 100644 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} module Cardano.Logging.Types ( Trace(..) @@ -20,7 +21,7 @@ module Cardano.Logging.Types ( , SeverityS(..) , SeverityF(..) , ConfigOption(..) - , RemoteAddr(..) + , ForwarderAddr(..) , FormatLogging(..) , TraceConfig(..) , emptyTraceConfig @@ -36,7 +37,8 @@ module Cardano.Logging.Types ( , PreFormatted(..) ) where -import Control.Tracer +-- import Control.Tracer +import Codec.Serialise (Serialise (..)) import qualified Control.Tracer as T import Data.Aeson ((.=)) import qualified Data.Aeson as AE @@ -51,13 +53,15 @@ import Data.Time (UTCTime) import GHC.Generics import Network.HostName (HostName) +import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) + -- | The Trace carries the underlying tracer Tracer from the contra-tracer package. -- It adds a 'LoggingContext' and maybe a 'TraceControl' to every message. newtype Trace m a = Trace - {unpackTrace :: Tracer m (LoggingContext, Maybe TraceControl, a)} + {unpackTrace :: T.Tracer m (LoggingContext, Maybe TraceControl, a)} -- | Contramap lifted to Trace -instance Monad m => Contravariant (Trace m) where +instance Monad m => T.Contravariant (Trace m) where contramap f (Trace tr) = Trace $ T.contramap (\ (lc, mbC, a) -> (lc, mbC, f a)) tr @@ -89,14 +93,14 @@ class LogFormatting a where data Metric -- | An integer metric. - -- If the text array is not empty it is used as namespace namespace - = IntM Namespace Integer + -- Text is used to name the metric + = IntM Text Integer -- | A double metric. - -- If the text array is not empty it is used as namespace - | DoubleM Namespace Double + -- Text is used to name the metric + | DoubleM Text Double -- | An counter metric. - -- If the text array is not empty it is used as namespace namespace - | CounterM Namespace (Maybe Int) + -- Text is used to name the metric + | CounterM Text (Maybe Int) deriving (Show, Eq) -- | A helper function for creating an |Object| given a list of pairs, named items, @@ -122,7 +126,7 @@ type Namespace = [Text] -- and a comment in markdown format data DocMsg a = DocMsg { dmPrototype :: a - , dmMetricsMD :: [(Namespace, Text)] + , dmMetricsMD :: [(Text, Text)] , dmMarkdown :: Text } deriving (Show) @@ -168,21 +172,41 @@ data SeverityS deriving (Show, Eq, Ord, Bounded, Enum) -- | Severity for a filter -data SeverityF - = DebugF -- ^ Debug messages - | InfoF -- ^ Information - | NoticeF -- ^ Normal runtime Conditions - | WarningF -- ^ General Warnings - | ErrorF -- ^ General Errors - | CriticalF -- ^ Severe situations - | AlertF -- ^ Take immediate action - | EmergencyF -- ^ System is unusable - | SilenceF -- ^ Don't show anything - deriving (Show, Eq, Ord, Bounded, Enum, Generic) +-- Nothing means don't show anything (Silence) +-- Nothing level means show messages with severity >= level +newtype SeverityF = SeverityF (Maybe SeverityS) + deriving (Eq) + +instance Enum SeverityF where + toEnum 8 = SeverityF Nothing + toEnum i = SeverityF (Just (toEnum i)) + fromEnum (SeverityF Nothing) = 8 + fromEnum (SeverityF (Just s)) = fromEnum s instance AE.ToJSON SeverityF where - toEncoding = AE.genericToEncoding AE.defaultOptions -instance AE.FromJSON SeverityF + toJSON (SeverityF (Just s)) = AE.String ((pack . show) s) + toJSON (SeverityF Nothing) = AE.String "Silence" + +instance AE.FromJSON SeverityF where + parseJSON (AE.String "Debug") = pure (SeverityF (Just Debug)) + parseJSON (AE.String "Info") = pure (SeverityF (Just Info)) + parseJSON (AE.String "Notice") = pure (SeverityF (Just Notice)) + parseJSON (AE.String "Warning") = pure (SeverityF (Just Warning)) + parseJSON (AE.String "Error") = pure (SeverityF (Just Error)) + parseJSON (AE.String "Critical") = pure (SeverityF (Just Critical)) + parseJSON (AE.String "Alert") = pure (SeverityF (Just Alert)) + parseJSON (AE.String "Emergency") = pure (SeverityF (Just Emergency)) + parseJSON (AE.String "Scilence") = pure (SeverityF Nothing) + +instance Ord SeverityF where + compare (SeverityF (Just s1)) (SeverityF (Just s2)) = compare s1 s2 + compare (SeverityF Nothing) (SeverityF Nothing) = EQ + compare (SeverityF (Just _s1)) (SeverityF Nothing) = LT + compare (SeverityF Nothing) (SeverityF (Just _s2)) = GT + +instance Show SeverityF where + show (SeverityF (Just s)) = show s + show (SeverityF Nothing) = "Silence" -- | Used as interface object for ForwarderTracer data TraceObject = TraceObject { @@ -239,28 +263,28 @@ data FormatLogging = -- Configuration options for individual namespace elements data ConfigOption = -- | Severity level for a filter (default is WarningF) - CoSeverity SeverityF + ConfSeverity SeverityF -- | Detail level (default is DNormal) - | CoDetail DetailLevel + | ConfDetail DetailLevel -- | To which backend to pass -- Default is [EKGBackend, Forwarder, Stdout HumanFormatColoured] - | CoBackend [BackendConfig] + | ConfBackend [BackendConfig] -- | Construct a limiter with name (Text) and limiting to the Double, -- which represents frequency in number of messages per second - | CoLimiter Text Double + | ConfLimiter Text Double deriving (Eq, Ord, Show) -newtype RemoteAddr +newtype ForwarderAddr = LocalSocket FilePath deriving (Eq, Ord, Show) -instance AE.FromJSON RemoteAddr where - parseJSON = AE.withObject "RemoteAddr" $ \o -> LocalSocket <$> o AE..: "filePath" +instance AE.FromJSON ForwarderAddr where + parseJSON = AE.withObject "ForwarderAddr" $ \o -> LocalSocket <$> o AE..: "filePath" data TraceConfig = TraceConfig { -- | Options specific to a certain namespace tcOptions :: Map.Map Namespace [ConfigOption] - , tcForwarder :: RemoteAddr + , tcForwarder :: ForwarderAddr , tcForwarderQueueSize :: Int } deriving (Eq, Ord, Show) @@ -282,13 +306,13 @@ data TraceControl where Reset :: TraceControl Config :: TraceConfig -> TraceControl Optimize :: TraceControl - Document :: Int -> Text -> [(Namespace, Text)] -> DocCollector -> TraceControl + Document :: Int -> Text -> [(Text, Text)] -> DocCollector -> TraceControl newtype DocCollector = DocCollector (IORef (Map Int LogDoc)) data LogDoc = LogDoc { ldDoc :: Text - , ldMetricsDoc :: Map Namespace Text + , ldMetricsDoc :: Map Text Text , ldNamespace :: [Namespace] , ldSeverity :: [SeverityS] , ldPrivacy :: [Privacy] @@ -298,10 +322,11 @@ data LogDoc = LogDoc { , ldLimiter :: [(Text, Double)] } deriving(Eq, Show) -emptyLogDoc :: Text -> [(Namespace, Text)] -> LogDoc +emptyLogDoc :: Text -> [(Text, Text)] -> LogDoc emptyLogDoc d m = LogDoc d (Map.fromList m) [] [] [] [] [] [] [] --- | Type for a Fold +-- | Type for the functions foldTraceM and foldMTraceM from module +-- Cardano/Logging/Trace newtype Folding a b = Folding b unfold :: Folding a b -> b @@ -333,14 +358,30 @@ instance LogFormatting b => LogFormatting (Folding a b) where instance LogFormatting Double where forMachine _dtal d = mkObject [ "val" .= AE.String ((pack . show) d)] forHuman d = (pack . show) d - asMetrics d = [DoubleM [] d] + asMetrics d = [DoubleM "" d] instance LogFormatting Int where forMachine _dtal i = mkObject [ "val" .= AE.String ((pack . show) i)] forHuman i = (pack . show) i - asMetrics i = [IntM [] (fromIntegral i)] + asMetrics i = [IntM "" (fromIntegral i)] instance LogFormatting Integer where forMachine _dtal i = mkObject [ "val" .= AE.String ((pack . show) i)] forHuman i = (pack . show) i - asMetrics i = [IntM [] i] + asMetrics i = [IntM "" i] + +--------------------------------------------------------------------------- +-- Instances for 'TraceObject' to forward it using 'trace-forward' library. + +deriving instance Generic Privacy +deriving instance Generic SeverityS +deriving instance Generic LoggingContext +deriving instance Generic TraceObject + +instance Serialise DetailLevel +instance Serialise Privacy +instance Serialise SeverityS +instance Serialise LoggingContext +instance Serialise TraceObject + +instance ShowProxy TraceObject diff --git a/trace-dispatcher/src/Cardano/Logging/Utils.hs b/trace-dispatcher/src/Cardano/Logging/Utils.hs new file mode 100644 index 00000000000..3e29ba58205 --- /dev/null +++ b/trace-dispatcher/src/Cardano/Logging/Utils.hs @@ -0,0 +1,8 @@ +module Cardano.Logging.Utils ( + uncurry3 + ) where + + +-- | Converts a curried function to a function on a triple. +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a,b,c) = f a b c diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Config.hs b/trace-dispatcher/test/Cardano/Logging/Test/Config.hs index 67bd46feb73..5689bb5a5f5 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Config.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Config.hs @@ -14,9 +14,9 @@ config1 :: TraceConfig config1 = emptyTraceConfig { tcOptions = fromList [([] :: Namespace, - [ CoSeverity DebugF - , CoDetail DNormal - , CoBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] + [ ConfSeverity (SeverityF (Just Debug)) + , ConfDetail DNormal + , ConfBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] ]) ] } @@ -25,19 +25,19 @@ config2 :: TraceConfig config2 = emptyTraceConfig { tcOptions = fromList [ ([] :: Namespace, - [ CoSeverity DebugF - , CoDetail DNormal - , CoBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] + [ ConfSeverity (SeverityF (Just Debug)) + , ConfDetail DNormal + , ConfBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] ]) , (["Node", "Test", "Message1"], - [ CoSeverity InfoF - , CoDetail DNormal - , CoBackend [Stdout HumanFormatColoured, EKGBackend] + [ ConfSeverity (SeverityF (Just Info)) + , ConfDetail DNormal + , ConfBackend [Stdout HumanFormatColoured, EKGBackend] ]) , (["Node", "Test", "Message2"], - [ CoSeverity ErrorF - , CoDetail DMinimal - , CoBackend [Forwarder, EKGBackend] + [ ConfSeverity (SeverityF (Just Error)) + , ConfDetail DMinimal + , ConfBackend [Forwarder, EKGBackend] ]) ] } diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Messages.hs b/trace-dispatcher/test/Cardano/Logging/Test/Messages.hs index 87af367c4e3..9b8814f9cbe 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Messages.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Messages.hs @@ -49,6 +49,6 @@ docMessage = Documented [ "The second message." , DocMsg (Message3 1 1.0) - [(["Metrics1"], "A number")] + [("Metrics1", "A number")] "The third message." ] diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs b/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs index 9f7947add1f..38bf34b3013 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs @@ -12,7 +12,7 @@ import Cardano.Logging testTracer :: MonadIO m => IORef [FormattedMessage] -> m (Trace m FormattedMessage) -testTracer ioRef = liftIO $ do +testTracer ioRef = liftIO $ pure $ Trace $ arrow $ emit output where output (LoggingContext{}, Nothing, msg) = liftIO $ do diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs index 5cbbab90dfd..4ed14bf2922 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs @@ -53,7 +53,7 @@ instance LogFormatting Message where forHuman (Message3 mid d) = "Message3 <" <> showT mid <> "> " <> showT d asMetrics (Message1 mid _i) = - [IntM ["Metrics1"] (fromIntegral mid)] + [IntM "Metrics1" (fromIntegral mid)] asMetrics _ = [] instance Arbitrary Message where diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal index 224732c202a..9d9df859b06 100644 --- a/trace-dispatcher/trace-dispatcher.cabal +++ b/trace-dispatcher/trace-dispatcher.cabal @@ -24,6 +24,7 @@ library Cardano.Logging.Tracer.Standard Cardano.Logging.Tracer.Forward Cardano.Logging.Tracer.Composed + Cardano.Logging.Utils Control.Tracer.Arrow Control.Tracer From 5d3bcf6e9250e1e28a307af8d9ca3a5939ee4c82 Mon Sep 17 00:00:00 2001 From: Kosyrev Serge Date: Fri, 1 Oct 2021 17:54:34 +0300 Subject: [PATCH 09/12] standard tracer: remove file output functionality --- .../examples/Examples/Aggregation.hs | 2 +- .../examples/Examples/Configuration.hs | 2 +- .../examples/Examples/Documentation.hs | 2 +- .../examples/Examples/FrequencyLimiting.hs | 2 +- trace-dispatcher/examples/Examples/Routing.hs | 2 +- trace-dispatcher/examples/Examples/Trivial.hs | 4 +- .../src/Cardano/Logging/Tracer/Standard.hs | 58 +++++++------------ 7 files changed, 27 insertions(+), 45 deletions(-) diff --git a/trace-dispatcher/examples/Examples/Aggregation.hs b/trace-dispatcher/examples/Examples/Aggregation.hs index 8fe0b12fc52..281933a8e14 100644 --- a/trace-dispatcher/examples/Examples/Aggregation.hs +++ b/trace-dispatcher/examples/Examples/Aggregation.hs @@ -51,7 +51,7 @@ calculate BaseStats{..} _ _ val = testAggregation :: IO () testAggregation = do - simpleTracer <- standardTracer Nothing + simpleTracer <- standardTracer formTracer <- humanFormatter True "cardano" simpleTracer tracer <- foldTraceM calculate emptyStats formTracer configureTracers emptyTraceConfig baseStatsDocumented [tracer] diff --git a/trace-dispatcher/examples/Examples/Configuration.hs b/trace-dispatcher/examples/Examples/Configuration.hs index 99fbd482bb3..f36d09ae26a 100644 --- a/trace-dispatcher/examples/Examples/Configuration.hs +++ b/trace-dispatcher/examples/Examples/Configuration.hs @@ -31,7 +31,7 @@ testMessageDocumented = Documented tracers :: MonadIO m => m (Trace m TestMessage, Trace m TestMessage) tracers = do - t <- standardTracer Nothing + t <- standardTracer t0 <- humanFormatter True "cardano" t t1 <- appendName "tracer1" <$> filterSeverityFromConfig t0 t2 <- appendName "tracer2" <$> filterSeverityFromConfig t0 diff --git a/trace-dispatcher/examples/Examples/Documentation.hs b/trace-dispatcher/examples/Examples/Documentation.hs index 261066f5d00..730c30ccc95 100644 --- a/trace-dispatcher/examples/Examples/Documentation.hs +++ b/trace-dispatcher/examples/Examples/Documentation.hs @@ -10,7 +10,7 @@ import Examples.TestObjects docTracers :: IO () docTracers = do - t <- standardTracer Nothing + t <- standardTracer t1' <- humanFormatter True "cardano" t let t1 = withSeverityTraceForgeEvent (appendName "node" t1') diff --git a/trace-dispatcher/examples/Examples/FrequencyLimiting.hs b/trace-dispatcher/examples/Examples/FrequencyLimiting.hs index d1909c0469d..91a56773aa9 100644 --- a/trace-dispatcher/examples/Examples/FrequencyLimiting.hs +++ b/trace-dispatcher/examples/Examples/FrequencyLimiting.hs @@ -16,7 +16,7 @@ repeated t n d = do testLimiting :: IO () testLimiting = do - t1 <- standardTracer Nothing + t1 <- standardTracer tf1 <- humanFormatter True "cardano" t1 tf2 <- limitFrequency 5 "5 messages per second" (appendName "tracer1" (contramap Message tf1)) diff --git a/trace-dispatcher/examples/Examples/Routing.hs b/trace-dispatcher/examples/Examples/Routing.hs index 93523d4f372..d54ca29e5c0 100644 --- a/trace-dispatcher/examples/Examples/Routing.hs +++ b/trace-dispatcher/examples/Examples/Routing.hs @@ -24,7 +24,7 @@ routingTracer2 t1 t2 = pure (t1 <> t2) testRouting :: IO () testRouting = do - t <- standardTracer Nothing + t <- standardTracer tf <- machineFormatter "cardano" t let t1 = appendName "tracer1" tf let t2 = appendName "tracer1" tf diff --git a/trace-dispatcher/examples/Examples/Trivial.hs b/trace-dispatcher/examples/Examples/Trivial.hs index 0d24b951abd..6628c30d011 100644 --- a/trace-dispatcher/examples/Examples/Trivial.hs +++ b/trace-dispatcher/examples/Examples/Trivial.hs @@ -13,7 +13,7 @@ import Examples.TestObjects -- for every path element test1 :: IO () test1 = do - stdoutTracer' <- standardTracer Nothing + stdoutTracer' <- standardTracer simpleTracer <- machineFormatter "cardano" stdoutTracer' configureTracers emptyTraceConfig traceForgeEventDocu [simpleTracer] let simpleTracer1 = filterTraceBySeverity @@ -31,7 +31,7 @@ test1 = do test2 :: IO () test2 = do - stdoutTracer' <- standardTracer Nothing + stdoutTracer' <- standardTracer simpleTracer <- humanFormatter True "cardano" stdoutTracer' configureTracers emptyTraceConfig traceForgeEventDocu [simpleTracer] let simpleTracer1 = withSeverity loSeverity diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs index c66596040ed..4aaaffc43fc 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs @@ -7,9 +7,10 @@ module Cardano.Logging.Tracer.Standard ( import Control.Concurrent.Async import Control.Concurrent.Chan.Unagi.Bounded -import Control.Monad (forever) +import Control.Monad (forever, when) import Control.Monad.IO.Class import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +import Data.Maybe (isNothing) import Data.Text (Text) import qualified Data.Text.IO as TIO import Data.Void (Void) @@ -21,30 +22,22 @@ import Cardano.Logging.Utils (uncurry3) import qualified Control.Tracer as T --- | Do we log to stdout or to a file? -data LogTarget = LogStdout | LogFile FilePath - deriving (Eq, Show) - -- | The state of a standard tracer -data StandardTracerState a = StandardTracerState { +newtype StandardTracerState = StandardTracerState { stRunning :: Maybe (InChan Text, OutChan Text, Async Void) - , stTarget :: LogTarget } -emptyStandardTracerState :: Maybe FilePath -> StandardTracerState a -emptyStandardTracerState Nothing = StandardTracerState Nothing LogStdout -emptyStandardTracerState (Just fp) = StandardTracerState Nothing (LogFile fp) - +emptyStandardTracerState :: StandardTracerState +emptyStandardTracerState = StandardTracerState Nothing standardTracer :: forall m. (MonadIO m) - => Maybe FilePath - -> m (Trace m FormattedMessage) -standardTracer mbFilePath = do - stateRef <- liftIO $ newIORef (emptyStandardTracerState mbFilePath) + => m (Trace m FormattedMessage) +standardTracer = do + stateRef <- liftIO $ newIORef emptyStandardTracerState pure $ Trace $ T.arrow $ T.emit $ uncurry3 (output stateRef) where output :: - IORef (StandardTracerState a) + IORef StandardTracerState -> LoggingContext -> Maybe TraceControl -> FormattedMessage @@ -62,9 +55,8 @@ standardTracer mbFilePath = do output stateRef LoggingContext {} (Just Reset) _msg = liftIO $ do st <- readIORef stateRef case stRunning st of - Nothing -> case stRunning st of - Just (inChannel, _, _) -> pure () - Nothing -> startWriterThread stateRef + Nothing -> when (isNothing $ stRunning st) $ + startStdoutThread stateRef Just _ -> pure () output _ lk (Just c@Document {}) (FormattedHuman co msg) = docIt @@ -75,28 +67,18 @@ standardTracer mbFilePath = do docIt (Stdout MachineFormat) (FormattedMachine "") (lk, Just c, msg) output _stateRef LoggingContext {} _ _a = pure () --- | Forks a new thread, which writes the messages either to stdout or a file -startWriterThread :: IORef (StandardTracerState a) -> IO () -startWriterThread stateRef = do +-- | Forks a new thread, which writes messages to stdout +startStdoutThread :: IORef StandardTracerState -> IO () +startStdoutThread stateRef = do (inChan, outChan) <- newChan 2048 - as <- async (writerThread stateRef outChan) + as <- async (stdoutThread outChan) modifyIORef stateRef (\ st -> st {stRunning = Just (inChan, outChan, as)}) - -- | The new thread, which does the actual write from the queue. -- runs forever, and never returns -writerThread :: - IORef (StandardTracerState a) - -> OutChan Text - -> IO Void -writerThread stateRef outChan = forever $ do - msg <- readChan outChan - state <- readIORef stateRef - case stTarget state of - LogFile f -> do - TIO.appendFile f msg - TIO.appendFile f "\n" - LogStdout -> do - TIO.putStrLn msg - hFlush stdout +stdoutThread :: OutChan Text -> IO Void +stdoutThread outChan = forever $ do + readChan outChan + >>= TIO.putStrLn + hFlush stdout From 4b68319e7a594bfd68dc40cb52efa4b68ffb4ea5 Mon Sep 17 00:00:00 2001 From: Denis Shevchenko Date: Mon, 4 Oct 2021 20:35:05 +0400 Subject: [PATCH 10/12] Update dependency: ekg-forward. --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 019035a5631..679725d429b 100644 --- a/cabal.project +++ b/cabal.project @@ -266,8 +266,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/ekg-forward - tag: d3e8a3abe2b55e72aca79212b053b4aabade91f4 - --sha256: 04gwrmkkq0ami6qff0vsi8i5m4qan6pv7jj76k2b88qhk0407wyj + tag: 2d6691dd8ff68a0be4d9c73912b9559c96b76a25 + --sha256: 00wlv9sx9jfnqf503mwvssf44q5lv0cq6virkdf6w25m3cnhx06w -- Drops an instance breaking our code. Should be released to Hackage eventually. source-repository-package From c9daebd3579033653d8dec93863c240bb78576ea Mon Sep 17 00:00:00 2001 From: Kosyrev Serge Date: Tue, 5 Oct 2021 01:36:15 +0300 Subject: [PATCH 11/12] trace-dispatcher: link the stdout thread to the init thread --- trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs index 4aaaffc43fc..c99fadb9cb5 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs @@ -72,6 +72,7 @@ startStdoutThread :: IORef StandardTracerState -> IO () startStdoutThread stateRef = do (inChan, outChan) <- newChan 2048 as <- async (stdoutThread outChan) + link as modifyIORef stateRef (\ st -> st {stRunning = Just (inChan, outChan, as)}) From ef3fd9b3d25099e2bcac26bba8ae2feb013cacb1 Mon Sep 17 00:00:00 2001 From: Kosyrev Serge Date: Tue, 5 Oct 2021 05:26:48 +0300 Subject: [PATCH 12/12] trace-resources: restore the ResourceStats HKD --- .../src/Cardano/Logging/Resources.hs | 4 +- .../src/Cardano/Logging/Resources/Darwin.hsc | 3 +- .../src/Cardano/Logging/Resources/Linux.hs | 3 +- .../src/Cardano/Logging/Resources/Types.hs | 78 +++++++++++++++---- .../src/Cardano/Logging/Resources/Windows.hsc | 3 +- 5 files changed, 69 insertions(+), 22 deletions(-) diff --git a/trace-resources/src/Cardano/Logging/Resources.hs b/trace-resources/src/Cardano/Logging/Resources.hs index 89677bb7335..0ebf3f1c94b 100644 --- a/trace-resources/src/Cardano/Logging/Resources.hs +++ b/trace-resources/src/Cardano/Logging/Resources.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} module Cardano.Logging.Resources - ( - ResourceStats(..) + ( Resources(..) + , ResourceStats , readResourceStats ) where diff --git a/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc b/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc index db5eb16e8c3..785218f69ff 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc +++ b/trace-resources/src/Cardano/Logging/Resources/Darwin.hsc @@ -88,7 +88,7 @@ readRessoureStatsInternal = getProcessID >>= \pid -> do rts <- GhcStats.getRTSStats mem <- getMemoryInfo pid pure . Just $ - ResourceStats + Resources { rCentiCpu = timeValToCenti (_user_time cpu) + timeValToCenti (_system_time cpu) , rCentiGC = nsToCenti $ GhcStats.gc_cpu_ns rts @@ -97,6 +97,7 @@ readRessoureStatsInternal = getProcessID >>= \pid -> do , rGcsMinor = fromIntegral $ GhcStats.gcs rts - GhcStats.major_gcs rts , rAlloc = GhcStats.allocated_bytes rts , rLive = GhcStats.gcdetails_live_bytes $ GhcStats.gc rts + , rHeap = GhcStats.gcdetails_mem_in_use_bytes $ GhcStats.gc rts , rRSS = _resident_size mem , rCentiBlkIO = 0 , rThreads = 0 diff --git a/trace-resources/src/Cardano/Logging/Resources/Linux.hs b/trace-resources/src/Cardano/Logging/Resources/Linux.hs index 10d0ac640fe..1d8c15e96f4 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Linux.hs +++ b/trace-resources/src/Cardano/Logging/Resources/Linux.hs @@ -28,7 +28,7 @@ readRessoureStatsInternal = do :_:_:_:rss:_:_:_:_:_:_ -- 20-29 :_:_:_:_:_:_:_:_:_:_ -- 30-39 :_:blkio:_rest) = -- 40-42 - Just $ ResourceStats + Just $ Resources { rCentiCpu = user + sys , rCentiGC = nsToCenti $ GhcStats.gc_cpu_ns rts , rCentiMut = nsToCenti $ GhcStats.mutator_cpu_ns rts @@ -36,6 +36,7 @@ readRessoureStatsInternal = do , rGcsMinor = fromIntegral $ GhcStats.gcs rts - GhcStats.major_gcs rts , rAlloc = GhcStats.allocated_bytes rts , rLive = GhcStats.gcdetails_live_bytes $ GhcStats.gc rts + , rHeap = GhcStats.gcdetails_mem_in_use_bytes $ GhcStats.gc rts , rRSS = rss * 4096 -- TODO: this is really PAGE_SIZE. , rCentiBlkIO = blkio , rThreads = threads diff --git a/trace-resources/src/Cardano/Logging/Resources/Types.hs b/trace-resources/src/Cardano/Logging/Resources/Types.hs index aac05869d45..6399b0219ef 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Types.hs +++ b/trace-resources/src/Cardano/Logging/Resources/Types.hs @@ -1,37 +1,81 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} module Cardano.Logging.Resources.Types - ( - ResourceStats(..) + ( Resources(..) + , ResourceStats , docResourceStats ) where import Cardano.Logging.Types -import Data.Aeson (Value (Number, String), (.=)) +import Data.Aeson import Data.Text (pack) import Data.Word +import GHC.Generics (Generic) -- | Struct for resources used by the process -data ResourceStats - = ResourceStats - { rCentiCpu :: !Word64 - , rCentiGC :: !Word64 - , rCentiMut :: !Word64 - , rGcsMajor :: !Word64 - , rGcsMinor :: !Word64 - , rAlloc :: !Word64 - , rLive :: !Word64 - , rRSS :: !Word64 - , rCentiBlkIO :: !Word64 - , rThreads :: !Word64 +type ResourceStats = Resources Word64 + +-- * HKD for resources used by the process. +-- +data Resources a + = Resources + { rCentiCpu :: !a + , rCentiGC :: !a + , rCentiMut :: !a + , rGcsMajor :: !a + , rGcsMinor :: !a + , rAlloc :: !a + , rLive :: !a + , rHeap :: !a + , rRSS :: !a + , rCentiBlkIO :: !a + , rThreads :: !a } - deriving (Show) + deriving (Functor, Generic, Show) + +instance Applicative Resources where + pure a = Resources a a a a a a a a a a a + f <*> x = + Resources + { rCentiCpu = rCentiCpu f (rCentiCpu x) + , rCentiGC = rCentiGC f (rCentiGC x) + , rCentiMut = rCentiMut f (rCentiMut x) + , rGcsMajor = rGcsMajor f (rGcsMajor x) + , rGcsMinor = rGcsMinor f (rGcsMinor x) + , rAlloc = rAlloc f (rAlloc x) + , rLive = rLive f (rLive x) + , rHeap = rHeap f (rHeap x) + , rRSS = rRSS f (rRSS x) + , rCentiBlkIO = rCentiBlkIO f (rCentiBlkIO x) + , rThreads = rThreads f (rThreads x) + } + +instance FromJSON a => FromJSON (Resources a) where + parseJSON = genericParseJSON jsonEncodingOptions + +instance ToJSON a => ToJSON (Resources a) where + toJSON = genericToJSON jsonEncodingOptions + toEncoding = genericToEncoding jsonEncodingOptions + +jsonEncodingOptions :: Options +jsonEncodingOptions = defaultOptions + { fieldLabelModifier = drop 1 + , tagSingleConstructors = True + , sumEncoding = + TaggedObject + { tagFieldName = "kind" + , contentsFieldName = "contents" + } + } docResourceStats :: Documented ResourceStats docResourceStats = Documented [ DocMsg - (ResourceStats 1 1 1 1 1 1 1 1 1 1) + (pure 0) [("Stat.Cputicks", "Reports the CPU ticks, sice the process was started") ,("Mem.Resident", "TODO JNF") ,("RTS.GcLiveBytes", "TODO JNF") diff --git a/trace-resources/src/Cardano/Logging/Resources/Windows.hsc b/trace-resources/src/Cardano/Logging/Resources/Windows.hsc index f10a11a8d50..e5f043fa688 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Windows.hsc +++ b/trace-resources/src/Cardano/Logging/Resources/Windows.hsc @@ -143,7 +143,7 @@ readRessoureStatsInternal = getCurrentProcessId >>= \pid -> do mem <- getMemoryInfo pid rts <- GhcStats.getRTSStats pure . Just $ - ResourceStats + Resources { rCentiCpu = usecsToCenti $ usertime cpu + systime cpu , rCentiGC = nsToCenti $ GhcStats.gc_cpu_ns rts , rCentiMut = nsToCenti $ GhcStats.mutator_cpu_ns rts @@ -151,6 +151,7 @@ readRessoureStatsInternal = getCurrentProcessId >>= \pid -> do , rGcsMinor = fromIntegral $ GhcStats.gcs rts - GhcStats.major_gcs rts , rAlloc = GhcStats.allocated_bytes rts , rLive = GhcStats.gcdetails_live_bytes $ GhcStats.gc rts + , rHeap = GhcStats.gcdetails_mem_in_use_bytes $ GhcStats.gc rts , rRSS = fromIntegral (_workingSetSize mem) , rCentiBlkIO = 0 , rThreads = 0