diff --git a/cabal.project b/cabal.project index 3393d1c..0661fbf 100644 --- a/cabal.project +++ b/cabal.project @@ -14,6 +14,7 @@ index-state: , cardano-haskell-packages 2026-03-19T11:07:17Z packages: + trace-dispatcher-api trace-dispatcher hermod-recon-framework diff --git a/perSystem/devShells.nix b/perSystem/devShells.nix index 6951b29..3b7ff6c 100644 --- a/perSystem/devShells.nix +++ b/perSystem/devShells.nix @@ -1,7 +1,7 @@ { inputs, ... }: { perSystem = { shellFor, pkgs, ... }: { devShells.default = shellFor { - packages = p: [ p.trace-dispatcher p.hermod-recon-framework ]; + packages = p: [ p.trace-dispatcher-api p.trace-dispatcher p.hermod-recon-framework ]; nativeBuildInputs = [ pkgs.jq diff --git a/perSystem/packages.nix b/perSystem/packages.nix index 72aaf6d..a34f107 100644 --- a/perSystem/packages.nix +++ b/perSystem/packages.nix @@ -1,12 +1,15 @@ { perSystem = { hsPkgs, ... }: let + tda = hsPkgs.trace-dispatcher-api; td = hsPkgs.trace-dispatcher; hrf = hsPkgs.hermod-recon-framework; in { - packages.trace-dispatcher = td.components.library; - checks.trace-dispatcher-test = td.components.tests.trace-dispatcher-test; + packages.trace-dispatcher-api = tda.components.library; + + packages.trace-dispatcher = td.components.library; + checks.trace-dispatcher-test = td.components.tests.trace-dispatcher-test; packages.hermod-recon = hrf.components.exes.hermod-recon; packages.hermod-recon-grep = hrf.components.exes.hermod-recon-grep; diff --git a/perSystem/project.nix b/perSystem/project.nix index 254184d..30e7307 100644 --- a/perSystem/project.nix +++ b/perSystem/project.nix @@ -13,7 +13,8 @@ }; modules = [{ - packages.trace-dispatcher.ghcOptions = [ "-Werror" "-fno-ignore-asserts" ]; + packages.trace-dispatcher-api.ghcOptions = [ "-Werror" "-fno-ignore-asserts" ]; + packages.trace-dispatcher.ghcOptions = [ "-Werror" "-fno-ignore-asserts" ]; packages.hermod-recon-framework.ghcOptions = [ "-Werror" "-fno-ignore-asserts" ]; }]; }); diff --git a/trace-dispatcher-api/LICENSE b/trace-dispatcher-api/LICENSE new file mode 100644 index 0000000..f433b1a --- /dev/null +++ b/trace-dispatcher-api/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/trace-dispatcher-api/NOTICE b/trace-dispatcher-api/NOTICE new file mode 100644 index 0000000..bb48c54 --- /dev/null +++ b/trace-dispatcher-api/NOTICE @@ -0,0 +1,13 @@ +Copyright 2020-2023 Input Output Global Inc (IOG), 2023-2026 Intersect. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/trace-dispatcher-api/src/Cardano/Logging/API.hs b/trace-dispatcher-api/src/Cardano/Logging/API.hs new file mode 100644 index 0000000..33bdeff --- /dev/null +++ b/trace-dispatcher-api/src/Cardano/Logging/API.hs @@ -0,0 +1,64 @@ +-- | Stable public API for the Hermod tracing system. +-- +-- This is the single-import front door for @trace-dispatcher-api@. It +-- re-exports everything a package needs to: +-- +-- * __Define trace types__: write 'LogFormatting' (human\/machine rendering, +-- metrics) and 'MetaTrace' (namespace, severity, documentation) instances +-- for your domain message types. +-- +-- * __Dispatch messages__: call 'traceWith' to emit, 'contramapM' \/ 'contramapM'' +-- to adapt types, 'foldTraceM' to accumulate state, 'routingTrace' to fan out. +-- +-- * __Filter and annotate__: 'filterTraceBySeverity', 'filterTraceByPrivacy', +-- 'withNames', 'setSeverity', 'setDetails', etc. +-- +-- == When to use this package vs. @trace-dispatcher@ +-- +-- Depend on @trace-dispatcher-api@ (and import this module) when your package +-- only needs to __define__ trace types and __call__ the core combinators — for +-- example, a library that instruments its own operations. You get a small +-- transitive closure with no I\/O backends, no config parser, no Prometheus. +-- +-- Depend on @trace-dispatcher@ (and import "Cardano.Logging") when you need +-- the __full stack__: backend constructors ('standardTracer', 'ekgTracer', +-- 'forwardTracer'), 'configureTracers', 'readConfiguration', and so on. +-- +-- == Types exported by this module +-- +-- === For tracer authors +-- +-- @ +-- Trace -- the central carrier type +-- LogFormatting(..) -- typeclass: forMachine, forHuman, asMetrics +-- MetaTrace(..) -- typeclass: namespaceFor, severityFor, documentFor, … +-- Metric(..) -- metric payload (IntM, DoubleM, CounterM, PrometheusM) +-- Namespace(..) -- hierarchical trace identifier +-- LoggingContext(..) -- per-message context (namespace, severity, privacy, detail) +-- SeverityS(..) -- message severity (Debug … Emergency) +-- SeverityF(..) -- severity filter (Nothing = Silence) +-- Privacy(..) -- Public | Confidential +-- DetailLevel(..) -- DMinimal … DMaximum +-- Folding(..) -- wrapper for fold-based stateful tracers +-- @ +-- +-- === Configuration and control (consumed by @trace-dispatcher@) +-- +-- 'TraceControl', 'TraceConfig', 'ConfigOption', 'BackendConfig', +-- 'ConfigReflection', 'DocCollector', 'LogDoc', 'ForwarderAddr', +-- 'ForwarderMode', 'TraceOptionForwarder', 'PrometheusSimpleRun'. +-- These appear in type signatures throughout the system; tracer authors +-- typically do not construct them directly. +module Cardano.Logging.API + ( module X + ) where + +-- Core types: Trace, LogFormatting, MetaTrace, Namespace, Metric, +-- LoggingContext, Severity, Privacy, DetailLevel, Folding, +-- TraceConfig, TraceControl, BackendConfig, … +import Cardano.Logging.Types as X + +-- Core combinators: traceWith, contramapM, contramapM', foldTraceM, +-- foldCondTraceM, routingTrace, filterTrace*, +-- withNames, setSeverity, setDetails, withLoggingContext, … +import Cardano.Logging.Trace as X diff --git a/trace-dispatcher-api/src/Cardano/Logging/Trace.hs b/trace-dispatcher-api/src/Cardano/Logging/Trace.hs new file mode 100644 index 0000000..a99aca4 --- /dev/null +++ b/trace-dispatcher-api/src/Cardano/Logging/Trace.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Per-message annotation and filtering combinators. +-- +-- These operations attach labels (severity, privacy, detail level, namespace) +-- to messages, or filter messages based on those labels. They wrap a +-- downstream 'Trace' and are composed left-to-right in the usual +-- contravariant style. +-- +-- For structural combinators that shape the pipeline ('traceWith', +-- 'contramapM', 'foldTraceM', 'routingTrace', …) see +-- "Cardano.Logging.Trace.Combinators", which this module re-exports. +module Cardano.Logging.Trace ( + module Cardano.Logging.Trace.Combinators + + , filterTrace + , filterTraceMaybe + , filterTraceBySeverity + , filterTraceByPrivacy + + , setSeverity + , withSeverity + , privately + , setPrivacy + , withPrivacy + , allPublic + , allConfidential + , setDetails + , withDetails + + , withNames + , appendPrefixName + , appendPrefixNames + , appendInnerName + , appendInnerNames + , withInnerNames +) where + +import Cardano.Logging.Trace.Combinators +import Cardano.Logging.Types + +import qualified Control.Tracer as T +import Data.Maybe (isJust) +import Data.Text (Text) + + +--- | Don't process further if the selector function returns 'False'. +filterTrace :: Monad m + => ((LoggingContext, a) -> Bool) + -> Trace m a + -> Trace m a +filterTrace ff (Trace tr) = Trace $ T.squelchUnless + (\case + (_lc, Left _) -> True + (lc, Right a) -> ff (lc, a)) + tr + +--- | Keep 'Just' values; discard 'Nothing'. +filterTraceMaybe :: Monad m + => Trace m a + -> Trace m (Maybe a) +filterTraceMaybe (Trace tr) = Trace $ + T.squelchUnless + (\case + (_lc, Left _ctrl) -> True + (_lc, Right (Just _)) -> True + (_lc, Right Nothing) -> False) + (T.contramap + (\case + ( lc, Right (Just a)) -> (lc, Right a) + (_lc, Right Nothing) -> error "filterTraceMaybe: impossible" + ( lc, Left ctrl) -> (lc, Left ctrl)) + tr) + +--- | Only process messages with severity ≥ the given minimum. +filterTraceBySeverity :: Monad m + => Maybe SeverityF + -> Trace m a + -> Trace m a +filterTraceBySeverity (Just minSeverity) = + filterTrace + (\(lc, _) -> case lcSeverity lc of + Just s -> case minSeverity of + SeverityF (Just fs) -> s >= fs + SeverityF Nothing -> False + Nothing -> True) +filterTraceBySeverity Nothing = id + +--- | Only process messages whose privacy level ≥ the given minimum. +filterTraceByPrivacy :: Monad m + => Maybe Privacy + -> Trace m a + -> Trace m a +filterTraceByPrivacy (Just minPrivacy) = filterTrace $ + \(lc, _cont) -> + case lcPrivacy lc of + Just s -> fromEnum s >= fromEnum minPrivacy + Nothing -> True +filterTraceByPrivacy Nothing = id + + +-- | Set a fixed 'SeverityS' on every message (no-op if already set). +setSeverity :: Monad m => SeverityS -> Trace m a -> Trace m a +setSeverity s (Trace tr) = Trace $ + T.contramap + (\(lc, cont) -> + if isJust (lcSeverity lc) + then (lc, cont) + else (lc {lcSeverity = Just s}, cont)) + tr + +-- | Set severity from the 'MetaTrace' instance for each message. +{-# INLINE withSeverity #-} +withSeverity :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a +withSeverity (Trace tr) = Trace $ + T.contramap + (\case + (lc, Right e) -> process lc (Right e) + (lc, Left c@(TCConfig _)) -> process lc (Left c) + (lc, Left d@(TCDocument _ _)) -> process lc (Left d) + (lc, Left e) -> (lc, Left e)) + tr + where + process lc cont@(Right v) = + if isJust (lcSeverity lc) + then (lc, cont) + else (lc {lcSeverity = severityFor (Namespace [] (lcNSInner lc) :: Namespace a) (Just v)}, cont) + process lc cont@(Left _) = + if isJust (lcSeverity lc) + then (lc, cont) + else (lc {lcSeverity = severityFor (Namespace [] (lcNSInner lc) :: Namespace a) Nothing}, cont) + + +allPublic :: a -> Privacy +allPublic _ = Public + +allConfidential :: a -> Privacy +allConfidential _ = Confidential + +-- | Set 'Confidential' privacy on every message. +privately :: Monad m => Trace m a -> Trace m a +privately = setPrivacy Confidential + +-- | Set a fixed 'Privacy' on every message (no-op if already set). +setPrivacy :: Monad m => Privacy -> Trace m a -> Trace m a +setPrivacy p (Trace tr) = Trace $ + T.contramap + (\(lc, cont) -> + if isJust (lcPrivacy lc) + then (lc, cont) + else (lc {lcPrivacy = Just p}, cont)) + tr + +-- | Set privacy from the 'MetaTrace' instance for each message. +withPrivacy :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a +withPrivacy (Trace tr) = Trace $ + T.contramap + (\case + (lc, Right e) -> process lc (Right e) + (lc, Left c@(TCConfig _)) -> process lc (Left c) + (lc, Left d@(TCDocument _ _)) -> process lc (Left d) + (lc, Left e) -> (lc, Left e)) + tr + where + process lc cont@(Right v) = + if isJust (lcPrivacy lc) + then (lc, cont) + else (lc {lcPrivacy = privacyFor (Namespace [] (lcNSInner lc) :: Namespace a) (Just v)}, cont) + process lc cont@(Left _) = + if isJust (lcPrivacy lc) + then (lc, cont) + else (lc {lcPrivacy = privacyFor (Namespace [] (lcNSInner lc) :: Namespace a) Nothing}, cont) + + +-- | Set a fixed 'DetailLevel' on every message (no-op if already set). +setDetails :: Monad m => DetailLevel -> Trace m a -> Trace m a +setDetails p (Trace tr) = Trace $ + T.contramap + (\(lc, cont) -> + if isJust (lcDetails lc) + then (lc, cont) + else (lc {lcDetails = Just p}, cont)) + tr + +-- | Set detail level from the 'MetaTrace' instance for each message. +withDetails :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a +withDetails (Trace tr) = Trace $ + T.contramap + (\case + (lc, Right e) -> process lc (Right e) + (lc, Left c@(TCConfig _)) -> process lc (Left c) + (lc, Left d@(TCDocument _ _)) -> process lc (Left d) + (lc, Left e) -> (lc, Left e)) + tr + where + process lc cont@(Right v) = + if isJust (lcDetails lc) + then (lc, cont) + else (lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc) :: Namespace a) (Just v)}, cont) + process lc cont@(Left _) = + if isJust (lcDetails lc) + then (lc, cont) + else (lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc) :: Namespace a) Nothing}, cont) + + +-- | Set prefix and inner namespace from the 'MetaTrace' instance for each +-- message, prepending the given prefix names. +{-# INLINE withNames #-} +withNames :: forall m a. (Monad m, MetaTrace a) => [Text] -> Trace m a -> Trace m a +withNames names (Trace tr) = Trace $ + T.contramap + (\case + (lc, Right a) -> (lc {lcNSPrefix = names, + lcNSInner = nsInner (namespaceFor a)}, Right a) + (lc, Left c) -> (lc {lcNSPrefix = names}, Left c)) + tr + +-- | Set inner namespace from the 'MetaTrace' instance for each message. +{-# INLINE withInnerNames #-} +withInnerNames :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a +withInnerNames (Trace tr) = Trace $ + T.contramap + (\case + (lc, Right a) -> (lc {lcNSInner = nsInner (namespaceFor a)}, Right a) + (lc, Left c) -> (lc, Left c)) + tr + +-- | Prepend a single name to the namespace prefix. +appendPrefixName :: Monad m => Text -> Trace m a -> Trace m a +appendPrefixName name (Trace tr) = Trace $ + T.contramap + (\(lc, cont) -> (lc {lcNSPrefix = name : lcNSPrefix lc}, cont)) + tr + +appendInnerName :: Monad m => Text -> Trace m a -> Trace m a +appendInnerName name (Trace tr) = Trace $ + T.contramap + (\(lc, cont) -> (lc {lcNSInner = name : lcNSInner lc}, cont)) + tr + +-- | Prepend several names to the namespace prefix. +{-# INLINE appendPrefixNames #-} +appendPrefixNames :: Monad m => [Text] -> Trace m a -> Trace m a +appendPrefixNames names (Trace tr) = Trace $ + T.contramap + (\(lc, cont) -> (lc {lcNSPrefix = names ++ lcNSPrefix lc}, cont)) + tr + +appendInnerNames :: Monad m => [Text] -> Trace m a -> Trace m a +appendInnerNames names (Trace tr) = Trace $ + T.contramap + (\(lc, cont) -> (lc {lcNSInner = names ++ lcNSInner lc}, cont)) + tr diff --git a/trace-dispatcher-api/src/Cardano/Logging/Trace/Combinators.hs b/trace-dispatcher-api/src/Cardano/Logging/Trace/Combinators.hs new file mode 100644 index 0000000..8ea338d --- /dev/null +++ b/trace-dispatcher-api/src/Cardano/Logging/Trace/Combinators.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Structural combinators for building and composing traces. +-- +-- These operations change the /shape/ of the pipeline: they adapt message +-- types, accumulate state, route messages to different tracers, and emit +-- messages into the underlying 'T.Tracer'. +-- +-- For filtering and per-message annotation (severity, privacy, detail, +-- namespace), see 'Cardano.Logging.Trace'. +module Cardano.Logging.Trace.Combinators ( + traceWith + , withLoggingContext + , contramapM + , contramapMCond + , contramapM' + , foldTraceM + , foldCondTraceM + , routingTrace + , contramap' + , (>!$!<) +) where + +import Cardano.Logging.Types + +import Control.Monad (forM_, join) +import Control.Monad.IO.Unlift +import qualified Control.Tracer as T +import Data.Functor.Contravariant as Contr (Contravariant, (>$<)) + +import UnliftIO.MVar + + +-- | Emit a message into a trace. +traceWith :: Monad m => Trace m a -> a -> m () +traceWith (Trace tr) a = T.traceWith tr (emptyLoggingContext, Right a) + +-- | Replace the logging context for all messages passing through this trace. +withLoggingContext :: Monad m => LoggingContext -> Trace m a -> Trace m a +withLoggingContext lc (Trace tr) = Trace $ + T.contramap (\(_lc, cont) -> (lc, cont)) tr + + +-- | Contramap a monadic function over a trace. +{-# INLINE contramapM #-} +contramapM :: Monad m + => Trace m b + -> ((LoggingContext, Either TraceControl a) + -> m (LoggingContext, Either TraceControl b)) + -> m (Trace m a) +contramapM (Trace tr) mFunc = + pure $ Trace $ T.Tracer $ T.emit rFunc + where + rFunc arg = do + res <- mFunc arg + T.traceWith tr res + +-- | Like 'contramapM' but can also filter out messages by returning 'Nothing'. +{-# INLINE contramapMCond #-} +contramapMCond :: Monad m + => Trace m b + -> ((LoggingContext, Either TraceControl a) + -> m (Maybe (LoggingContext, Either TraceControl b))) + -> m (Trace m a) +contramapMCond (Trace tr) mFunc = + pure $ Trace $ T.Tracer $ T.emit rFunc + where + rFunc arg = do + condMes <- mFunc arg + forM_ condMes (T.traceWith tr) + +-- | Build a trace from a raw monadic action. +{-# INLINE contramapM' #-} +contramapM' :: Monad m + => ((LoggingContext, Either TraceControl a) -> m ()) + -> Trace m a +contramapM' rFunc = + Trace $ T.Tracer $ T.emit rFunc + + +-- | Fold a monadic accumulator function over a trace. +-- Uses an 'MVar' to hold the state. +foldTraceM :: forall a acc m . (MonadUnliftIO m) + => (acc -> LoggingContext -> a -> m acc) + -> acc + -> Trace m (Folding a acc) + -> m (Trace m a) +foldTraceM cata initial (Trace tr) = do + ref <- liftIO (newMVar initial) + contramapM (Trace tr) + (\case + (lc, Right v) -> do + x' <- modifyMVar ref $ \x -> do + !accu <- cata x lc v + pure $ join (,) accu + pure (lc, Right (Folding x')) + (lc, Left control) -> + pure (lc, Left control)) + +-- | Like 'foldTraceM' but additionally filter the trace by a predicate. +foldCondTraceM :: forall a acc m . (MonadUnliftIO m) + => (acc -> LoggingContext -> a -> m acc) + -> acc + -> (a -> Bool) + -> Trace m (Folding a acc) + -> m (Trace m a) +foldCondTraceM cata initial flt (Trace tr) = do + ref <- liftIO (newMVar initial) + contramapMCond (Trace tr) (foldF ref) + where + foldF ref = + \case + (lc, Right v) -> do + x' <- modifyMVar ref $ \x -> do + !accu <- cata x lc v + pure $ join (,) accu + if flt v + then pure $ Just (lc, Right (Folding x')) + else pure Nothing + (lc, Left control) -> + pure $ Just (lc, Left control) + +-- | Route messages to different tracers based on the message content. +-- +-- 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 + -> Trace m a +routingTrace rf rc = contramapM' + (\case + (lc, Right a) -> do + nt <- rf a + T.traceWith (unpackTrace nt) (lc, Right a) + (lc, Left control) -> + T.traceWith (unpackTrace rc) (lc, Left control)) + + +-- | A strict contramap that evaluates both the function and the result to WHNF, +-- avoiding accidental space leaks when composing deep tracer chains. +-- +-- The infix alias is '(>!$!<)'. +contramap', (>!$!<) :: Contravariant f => (a' -> a) -> (f a -> f a') + +contramap' a !b = + let !result = a Contr.>$< b + in result + +infixl 4 >!$!< + +(>!$!<) = contramap' diff --git a/trace-dispatcher-api/src/Cardano/Logging/Types.hs b/trace-dispatcher-api/src/Cardano/Logging/Types.hs new file mode 100644 index 0000000..20da290 --- /dev/null +++ b/trace-dispatcher-api/src/Cardano/Logging/Types.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} + +-- | Core tracing machinery: the 'Trace' carrier, the 'TraceControl' GADT that +-- flows in-band through the pipeline, and the two key typeclasses +-- ('LogFormatting', 'MetaTrace') that message types implement. +-- +-- This module re-exports 'Cardano.Logging.Types.Annotations', +-- 'Cardano.Logging.Types.Config', and 'Cardano.Logging.Types.Doc', so a +-- single @import Cardano.Logging.Types@ gives access to the full type +-- hierarchy. +module Cardano.Logging.Types ( + module Cardano.Logging.Types.Annotations + , module Cardano.Logging.Types.Config + , module Cardano.Logging.Types.Doc + , Trace(..) + , LogFormatting(..) + , MetaTrace(..) + , TraceControl(..) + , Folding(..) + , unfold +) where + +import Cardano.Logging.Types.Annotations +import Cardano.Logging.Types.Config +import Cardano.Logging.Types.Doc + +import qualified Control.Tracer as T +import qualified Data.Aeson as AE +import Data.Text (Text) + + +-- | The Trace carries the underlying 'T.Tracer' from the @contra-tracer@ +-- package. It adds a 'LoggingContext' and maybe a 'TraceControl' to every +-- message. +newtype Trace m a = Trace + { unpackTrace :: T.Tracer m (LoggingContext, Either TraceControl a) } + +-- | Contramap lifted to Trace. +instance Monad m => T.Contravariant (Trace m) where + contramap f (Trace tr) = Trace $ + T.contramap (\case + (lc, Right a) -> (lc, Right (f a)) + (lc, Left tc) -> (lc, Left tc)) + 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 + + +-- | When configuring a net of tracers, it should be run with 'TCConfig' on all +-- entry points first, and then with 'TCOptimize'. When reconfiguring, run +-- 'TCReset' followed by 'TCConfig' followed by 'TCOptimize'. +data TraceControl where + TCReset :: TraceControl + TCConfig :: TraceConfig -> TraceControl + TCOptimize :: ConfigReflection -> TraceControl + TCDocument :: Int -> DocCollector -> TraceControl + + +-- | Every message type needs this to define how to represent itself. +class LogFormatting a where + -- | Machine-readable representation with the possibility to render at varying + -- verbosities. This will result in JSON formatted log output. + -- A @forMachine@ implementation is required for any instance definition. + forMachine :: DetailLevel -> a -> AE.Object + + -- | Human-readable representation. + -- The empty text indicates there is no specific human-readable formatting + -- for that type — the default implementation. + -- + -- If human-readable output is explicitly requested, the system will fall + -- back to a JSON object conforming to the @forMachine@ definition, + -- rendering it as @{\"data\": \}@. + forHuman :: a -> Text + forHuman _v = "" + + -- | Metrics representation. + -- The default indicates that no metric is based on trace occurrences of + -- that type. + asMetrics :: a -> [Metric] + asMetrics _v = [] + + +class MetaTrace a where + namespaceFor :: a -> Namespace a + + severityFor :: Namespace a -> Maybe a -> Maybe SeverityS + privacyFor :: Namespace a -> Maybe a -> Maybe Privacy + privacyFor _ _ = Just Public + detailsFor :: Namespace a -> Maybe a -> Maybe DetailLevel + detailsFor _ _ = Just DNormal + + documentFor :: Namespace a -> Maybe Text + metricsDocFor :: Namespace a -> [(Text, Text)] + metricsDocFor _ = [] + allNamespaces :: [Namespace a] + + +-- | Wrapper used by 'Cardano.Logging.Trace.foldTraceM' to carry the +-- accumulated value alongside the original message type. +newtype Folding a b = Folding b + +unfold :: Folding a b -> b +unfold (Folding b) = b + +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 diff --git a/trace-dispatcher-api/src/Cardano/Logging/Types/Annotations.hs b/trace-dispatcher-api/src/Cardano/Logging/Types/Annotations.hs new file mode 100644 index 0000000..4940618 --- /dev/null +++ b/trace-dispatcher-api/src/Cardano/Logging/Types/Annotations.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Per-message annotation types: severity, privacy, detail level, namespace, +-- metrics, and the logging context that bundles them all. +-- +-- These types are pure (no IO) and carry no configuration — they describe +-- individual trace messages, not the pipeline that processes them. +module Cardano.Logging.Types.Annotations ( + Namespace(..) + , nsReplacePrefix + , nsReplaceInner + , nsCast + , nsPrependInner + , nsGetComplete + , nsGetTuple + , nsRawToText + , nsToText + , DetailLevel(..) + , Privacy(..) + , SeverityS(..) + , SeverityF(..) + , Metric(..) + , getMetricName + , LoggingContext(..) + , emptyLoggingContext +) where + +import Codec.Serialise (Serialise (..)) +import Control.DeepSeq (NFData) +import qualified Data.Aeson as AE +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics + + +-- | A unique identifier for every message, composed of text. +-- +-- A namespace can appear with a tracer name prefix +-- (e.g. @"ChainDB.OpenEvent.OpenedDB"@). +data Namespace a = Namespace { + nsPrefix :: [Text] + , nsInner :: [Text]} + deriving stock Eq + +instance Show (Namespace a) where + show (Namespace [] []) = "emptyNS" + show (Namespace [] nsInner') = + T.unpack $ T.intercalate (T.singleton '.') nsInner' + show (Namespace nsPrefix' nsInner') = + T.unpack $ T.intercalate (T.singleton '.') (nsPrefix' ++ nsInner') + +nsReplacePrefix :: [Text] -> Namespace a -> Namespace a +nsReplacePrefix o (Namespace _ i) = Namespace o i + +nsReplaceInner :: [Text] -> Namespace a -> Namespace a +nsReplaceInner i (Namespace o _) = Namespace o i + +nsPrependInner :: Text -> Namespace a -> Namespace b +nsPrependInner t (Namespace o i) = Namespace o (t : i) + +{-# INLINE nsCast #-} +nsCast :: Namespace a -> Namespace b +nsCast (Namespace o i) = Namespace o i + +nsGetComplete :: Namespace a -> [Text] +nsGetComplete (Namespace [] i) = i +nsGetComplete (Namespace o i) = o ++ i + +nsGetTuple :: Namespace a -> ([Text], [Text]) +nsGetTuple (Namespace o i) = (o, i) + +nsRawToText :: ([Text], [Text]) -> Text +nsRawToText = nsToText . uncurry Namespace + +nsToText :: Namespace a -> Text +nsToText (Namespace ns1 ns2) = T.intercalate "." (ns1 ++ ns2) + + +-- | The detail level facilitates rendering the same trace value to messages +-- with varying verbosities in its @instance LogFormatting@. +data DetailLevel = + DMinimal + | DNormal + | DDetailed + | DMaximum + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + deriving anyclass (Serialise, AE.FromJSON, NFData) + +instance AE.ToJSON DetailLevel where + toEncoding = AE.genericToEncoding AE.defaultOptions + + +-- | Privacy of a message. Default is 'Public'. +data Privacy = + Confidential -- ^ confidential information — handle with care + | Public -- ^ can be public + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + deriving anyclass Serialise + + +-- | Severity of a message. These are defined alongside message namespaces in +-- an @instance MetaTrace@. +-- +-- The severities and their semantics adhere to those defined in the +-- [Syslog Protocol](https://www.rfc-editor.org/rfc/rfc5424#section-6.2.1). +data SeverityS + = Debug -- ^ Debug messages + | Info -- ^ Informational — confirmation the program is working as expected + | Notice -- ^ Normal, but significant conditions — may require special handling + | Warning -- ^ General Warnings + | Error -- ^ General Errors + | Critical -- ^ Severe situations + | Alert -- ^ Take immediate action + | Emergency -- ^ System is unusable + deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Generic) + deriving anyclass (AE.ToJSON, AE.FromJSON, Serialise, NFData) + + +-- | Severity for a filter. These are supplied by a concrete configuration of +-- how to filter the entire message namespace at runtime. +-- +-- @Nothing@ means: filter everything ('Silence'). +-- +-- @Just severity@ means: render messages with @SeverityS >= severity@. +newtype SeverityF = SeverityF (Maybe SeverityS) + deriving stock 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 + toJSON (SeverityF (Just s)) = AE.String (T.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 "Silence") = pure (SeverityF Nothing) + parseJSON invalid = fail $ "Parsing of filter Severity failed." + <> "Unknown severity: " <> show invalid + +instance Ord SeverityF where + compare (SeverityF (Just s1)) (SeverityF (Just s2)) = compare s1 s2 + compare (SeverityF Nothing) (SeverityF Nothing) = EQ + compare (SeverityF (Just _)) (SeverityF Nothing) = LT + compare (SeverityF Nothing) (SeverityF (Just _)) = GT + +instance Show SeverityF where + show (SeverityF (Just s)) = show s + show (SeverityF Nothing) = "Silence" + + +-- | This type defines metrics, and how to update them. +-- +-- The @Text@ field always contains the metric name. +-- Metric names are recommended to conform to the +-- [Prometheus data model](https://prometheus.io/docs/concepts/data_model/#metric-names-and-labels). +-- If you want to structure your metrics in namespaces, please use a dot separator, +-- such as @"name.space.metricName"@. +-- +-- Example, defining three metrics based on the occurrence of a single trace event: +-- +-- > data Trace = BatchProcessed { batchSize :: Int } +-- > +-- > instance LogFormatting Trace where +-- > asMetrics (BatchProcessed size) = +-- > [ IntM "batch.current" (fromIntegral size) -- element count of the most recent batch +-- > , CounterM "batchesTotal" Nothing -- total batches processed (increment by 1) +-- > , CounterM "batch.total" (Just $ fromIntegral size) -- total elements processed +-- > ] +data Metric + = IntM Text Integer + -- ^ An integer gauge metric. Gauges are variable values. + | DoubleM Text Double + -- ^ A floating-point gauge metric. Gauges are variable values. + | CounterM Text (Maybe Int) + -- ^ A counter metric. Counters are non-negative, monotonically increasing values. + | PrometheusM Text [(Text, Text)] + -- ^ A label set containing the specified key-value pairs. + -- The OpenMetrics standard permits empty label sets; the value of this labeled + -- metric will always be @\"1\"@. + -- + -- For instance, a @PrometheusM "foo" [("key1", "value1"), ("key2", "value2")]@ + -- will be exposed as /"foo{key1=\"value1\",key2=\"value2\"} 1"/ + deriving stock (Eq, Show, Generic) + deriving anyclass NFData + +getMetricName :: Metric -> Text +getMetricName (IntM name _) = name +getMetricName (DoubleM name _) = name +getMetricName (CounterM name _) = name +getMetricName (PrometheusM name _) = name + + +-- | Context every log message carries. +data LoggingContext = LoggingContext { + lcNSInner :: [Text] + , lcNSPrefix :: [Text] + , lcSeverity :: Maybe SeverityS + , lcPrivacy :: Maybe Privacy + , lcDetails :: Maybe DetailLevel + } + deriving stock (Show, Generic) + deriving anyclass Serialise + +emptyLoggingContext :: LoggingContext +emptyLoggingContext = LoggingContext [] [] Nothing Nothing Nothing diff --git a/trace-dispatcher-api/src/Cardano/Logging/Types/Config.hs b/trace-dispatcher-api/src/Cardano/Logging/Types/Config.hs new file mode 100644 index 0000000..f41fdf5 --- /dev/null +++ b/trace-dispatcher-api/src/Cardano/Logging/Types/Config.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-partial-fields #-} + +-- | Configuration types for the tracing pipeline: backend selection, forwarder +-- options, Prometheus tuning, and the per-namespace config map. +-- +-- These types are consumed by @trace-dispatcher@ when wiring up backends and +-- applying a @TraceConfig@ to a live tracer net. Tracer authors writing +-- 'Cardano.Logging.Types.LogFormatting' or 'Cardano.Logging.Types.MetaTrace' +-- instances typically do not need this module directly. +module Cardano.Logging.Types.Config ( + FormatLogging(..) + , ConfigOption(..) + , ForwarderAddr(..) + , ForwarderMode(..) + , Verbosity(..) + , TraceOptionForwarder(..) + , defaultForwarder + , BackendConfig(..) + , parsePrometheusString + , PrometheusSimpleRun(..) + , prometheusSimpleNoOverrides + , TraceConfig(..) + , emptyTraceConfig +) where + +import Cardano.Logging.Types.Annotations (DetailLevel, SeverityF) + +import qualified Data.Aeson as AE +import Data.Bool (bool) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Read (decimal) +import GHC.Generics +import Network.HostName (HostName) +import Network.Socket (PortNumber) + + +data FormatLogging = + HumanFormatColoured + | HumanFormatUncoloured + | MachineFormat + deriving stock (Eq, Ord, Show) + + +-- | Configuration options for individual namespace elements. +data ConfigOption = + -- | Severity level for a filter (default is Warning). + ConfSeverity {severity :: SeverityF} + -- | Detail level (default is DNormal). + | ConfDetail {detail :: DetailLevel} + -- | To which backend to pass. + -- Default is @[EKGBackend, Forwarder, Stdout MachineFormat]@. + | ConfBackend {backends :: [BackendConfig]} + -- | Construct a limiter with limiting to the Double, + -- which represents frequency in number of messages per second. + | ConfLimiter {maxFrequency :: Double} + deriving stock (Eq, Ord, Show, Generic) + + +-- | Which network address the forwarder connects to. +newtype ForwarderAddr + = LocalSocket FilePath + deriving stock (Eq, Ord, Show) + +instance AE.FromJSON ForwarderAddr where + parseJSON = AE.withObject "ForwarderAddr" $ \o -> + LocalSocket <$> o AE..: "filePath" + + +-- | Whether the forwarder acts as client (Initiator) or server (Responder). +data ForwarderMode = + -- | Forwarder works as a client: it initiates network connection with + -- @cardano-tracer@ and/or another Haskell acceptor application. + Initiator + -- | Forwarder works as a server: it accepts network connection from + -- @cardano-tracer@ and/or another Haskell acceptor application. + | Responder + deriving stock (Eq, Ord, Show, Generic) + +instance AE.FromJSON ForwarderMode where + parseJSON (AE.String "Initiator") = pure Initiator + parseJSON (AE.String "Responder") = pure Responder + parseJSON other = fail $ "Parsing of ForwarderMode failed." + <> "Unknown ForwarderMode: " <> show other + + +data Verbosity = + -- | Maximum verbosity for all tracers in the forwarding protocols. + Maximum + -- | Minimum verbosity, the forwarding will work as silently as possible. + | Minimum + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass AE.ToJSON + +instance AE.FromJSON Verbosity where + parseJSON (AE.String "Maximum") = pure Maximum + parseJSON (AE.String "Minimum") = pure Minimum + parseJSON other = fail $ "Parsing of Verbosity failed." + <> "Unknown Verbosity: " <> show other + + +data TraceOptionForwarder = TraceOptionForwarder { + tofQueueSize :: Word + , tofVerbosity :: Verbosity + , tofMaxReconnectDelay :: Word + } deriving stock (Eq, Ord, Show, Generic) + +-- A word regarding queue size: +-- +-- In case of a missing forwarding service consumer, traces messages will be +-- buffered. This mitigates short forwarding interruptions, or delays at startup +-- time. +-- +-- The queue capacity should thus correlate to the expected log lines per second +-- given a particular tracing configuration - to avoid unnecessarily increasing +-- memory footprint. +-- +-- The default values here are chosen to accomodate verbose tracing output +-- (i.e., buffering 1min worth of trace data given ~32 messages per second). A +-- config that results in less than 5 msgs per second should also provide +-- `TraceOptionForwarder` a queue size value considerably lower. +-- +-- The queue size ties in with the max number of trace objects cardano-tracer +-- requests periodically, the default for that being 100. Here, the queue can +-- hold enough traces for 10 subsequent polls by cardano-tracer. +instance AE.FromJSON TraceOptionForwarder where + parseJSON = AE.withObject "TraceOptionForwarder" $ \obj -> do + -- Field "queueSize" is the new field that replaces and unifies + -- both "connQueueSize" and "disconnQueueSize". + maybeQueueSize <- obj AE..:? "queueSize" + queueSize <- case maybeQueueSize of + (Just qs) -> return qs + Nothing -> do + connQueueSize <- obj AE..:? "connQueueSize" AE..!= 128 + disconnQueueSize <- obj AE..:? "disconnQueueSize" AE..!= 192 + return $ max connQueueSize disconnQueueSize + verbosity <- obj AE..:? "verbosity" AE..!= Minimum + maxReconnectDelay <- obj AE..:? "maxReconnectDelay" AE..!= 45 + return $ TraceOptionForwarder queueSize verbosity maxReconnectDelay + +instance AE.ToJSON TraceOptionForwarder where + toJSON TraceOptionForwarder{..} = AE.object + [ "queueSize" AE..= tofQueueSize + , "verbosity" AE..= tofVerbosity + , "maxReconnectDelay" AE..= tofMaxReconnectDelay + ] + +defaultForwarder :: TraceOptionForwarder +defaultForwarder = TraceOptionForwarder + { tofQueueSize = 192 + , tofVerbosity = Minimum + , tofMaxReconnectDelay = 45 + } + + +data BackendConfig = + Forwarder + | Stdout FormatLogging + | EKGBackend + | DatapointBackend + | PrometheusSimple Bool (Maybe HostName) PortNumber + -- ^ Boolean: drop suffixes like @_int@ in exposition; default: False. + deriving stock (Eq, Ord, Show, Generic) + +instance AE.ToJSON BackendConfig where + toJSON Forwarder = AE.String "Forwarder" + toJSON DatapointBackend = AE.String "DatapointBackend" + toJSON EKGBackend = AE.String "EKGBackend" + toJSON (Stdout f) = AE.String $ "Stdout " <> T.pack (show f) + toJSON (PrometheusSimple s h p) = AE.String $ "PrometheusSimple " + <> bool mempty "nosuffix" s + <> maybe mempty ((<> " ") . T.pack) h + <> T.pack (show p) + +instance AE.FromJSON BackendConfig where + parseJSON = AE.withText "BackendConfig" $ \case + "Forwarder" -> pure Forwarder + "EKGBackend" -> pure EKGBackend + "DatapointBackend" -> pure DatapointBackend + "Stdout HumanFormatColoured" -> pure $ Stdout HumanFormatColoured + "Stdout HumanFormatUncoloured" -> pure $ Stdout HumanFormatUncoloured + "Stdout MachineFormat" -> pure $ Stdout MachineFormat + prometheus -> either fail pure (parsePrometheusString prometheus) + +parsePrometheusString :: Text -> Either String BackendConfig +parsePrometheusString t = case T.words t of + ["PrometheusSimple", portNo_] -> + parsePort portNo_ >>= Right . PrometheusSimple False Nothing + ["PrometheusSimple", arg, portNo_] -> + parsePort portNo_ >>= Right . + if validSuffix arg + then PrometheusSimple (isNoSuffix arg) Nothing + else PrometheusSimple False (Just $ T.unpack arg) + ["PrometheusSimple", noSuff, host, portNo_] + | validSuffix noSuff -> parsePort portNo_ >>= Right . PrometheusSimple (isNoSuffix noSuff) (Just $ T.unpack host) + | otherwise -> Left $ "invalid modifier for PrometheusSimple: " ++ show noSuff + _ -> Left $ "unknown backend: " ++ show t + where + validSuffix s = s == "suffix" || s == "nosuffix" + isNoSuffix = (== "nosuffix") + parsePort p = case decimal p of + Right (portNo :: Word, rest) + | T.null rest && 0 < portNo && portNo < 65536 -> Right $ fromIntegral portNo + _ -> Left $ "invalid PrometheusSimple port: " ++ show p + + +-- | Parameter overrides for PrometheusSimple DoS protection. +data PrometheusSimpleRun = PrometheusSimpleRun + { connTimeout :: Maybe Word -- ^ Release socket after inactivity (seconds); default: 22 + , connCountGlobal :: Maybe Word -- ^ Limit total number of incoming connections; default: 16 + , connCountPerHost :: Maybe Word -- ^ Limit number of incoming connections from the same host; default: 5 + , connPerSecond :: Maybe Double -- ^ Limit requests per second (may be < 1.0); default: 8.0 + } + deriving stock (Show, Generic) + deriving anyclass (AE.FromJSON, AE.ToJSON) + +prometheusSimpleNoOverrides :: PrometheusSimpleRun +prometheusSimpleNoOverrides = PrometheusSimpleRun Nothing Nothing Nothing Nothing + + +data TraceConfig = TraceConfig { + -- | Options specific to a certain namespace. + tcOptions :: Map [Text] [ConfigOption] + -- | Options for the forwarder. + , tcForwarder :: Maybe TraceOptionForwarder + -- | Optional human-readable name of the node. + , tcNodeName :: Maybe Text + -- | Optional prefix for metrics. + , tcMetricsPrefix :: Maybe Text + -- | Optional resource trace frequency in milliseconds. + , tcResourceFrequency :: Maybe Int + -- | Optional ledger metrics frequency in milliseconds. + , tcLedgerMetricsFrequency :: Maybe Int + -- | Optional parameter overrides for PrometheusSimple DoS protection. + , tcPrometheusSimpleRun :: Maybe PrometheusSimpleRun + } + deriving stock Show + +emptyTraceConfig :: TraceConfig +emptyTraceConfig = TraceConfig + { tcOptions = Map.empty + , tcForwarder = Nothing + , tcNodeName = Nothing + , tcMetricsPrefix = Nothing + , tcResourceFrequency = Nothing + , tcLedgerMetricsFrequency = Nothing + , tcPrometheusSimpleRun = Nothing + } diff --git a/trace-dispatcher-api/src/Cardano/Logging/Types/Doc.hs b/trace-dispatcher-api/src/Cardano/Logging/Types/Doc.hs new file mode 100644 index 0000000..63ee92b --- /dev/null +++ b/trace-dispatcher-api/src/Cardano/Logging/Types/Doc.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DerivingStrategies #-} + +-- | In-process documentation and reflection types. +-- +-- 'DocCollector' and 'LogDoc' are written by the doc-generator pass +-- (triggered by a 'Cardano.Logging.Types.TCDocument' control message) and +-- read back by tooling to produce human-readable documentation of a live +-- tracer configuration. +-- +-- 'ConfigReflection' is filled by the 'Cardano.Logging.Types.TCOptimize' +-- pass: it records which namespaces are silenced or metric-less so that the +-- optimised tracer can skip unnecessary work at runtime. +module Cardano.Logging.Types.Doc ( + ConfigReflection(..) + , emptyConfigReflection + , DocCollector(..) + , LogDoc(..) + , emptyLogDoc +) where + +import Cardano.Logging.Types.Annotations (DetailLevel, Privacy, + SeverityF, SeverityS) +import Cardano.Logging.Types.Config (BackendConfig) + +import Data.IORef +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) + + +-- | Mutable sets written during the 'TCOptimize' pass. +-- +-- After optimisation, 'crSilent' contains the namespaces whose effective +-- severity filter is @Silence@, and 'crNoMetrics' those that produce no +-- metrics — allowing tracers to skip formatting work for those paths. +data ConfigReflection = ConfigReflection { + crSilent :: IORef (Set [Text]) + , crNoMetrics :: IORef (Set [Text]) + , crAllTracers :: IORef (Set [Text]) + } + +emptyConfigReflection :: IO ConfigReflection +emptyConfigReflection = do + silence <- newIORef Set.empty + hasMetrics <- newIORef Set.empty + allTracers <- newIORef Set.empty + pure $ ConfigReflection silence hasMetrics allTracers + + +-- | A mutable map from namespace index to 'LogDoc', populated by the +-- 'TCDocument' control pass. +newtype DocCollector = DocCollector (IORef (Map Int LogDoc)) + + +-- | Documentation record for a single traced namespace. +data LogDoc = LogDoc { + ldDoc :: !Text + , ldMetricsDoc :: !(Map Text Text) + , ldNamespace :: ![([Text], [Text])] + , ldSeverityCoded :: !(Maybe SeverityS) + , ldPrivacyCoded :: !(Maybe Privacy) + , ldDetailsCoded :: !(Maybe DetailLevel) + , ldDetails :: ![DetailLevel] + , ldBackends :: ![BackendConfig] + , ldFiltered :: ![SeverityF] + , ldLimiter :: ![(Text, Double)] + , ldSilent :: Bool + } deriving stock (Eq, Show) + +emptyLogDoc :: Text -> [(Text, Text)] -> LogDoc +emptyLogDoc d m = + LogDoc d (Map.fromList m) [] Nothing Nothing Nothing [] [] [] [] False diff --git a/trace-dispatcher-api/trace-dispatcher-api.cabal b/trace-dispatcher-api/trace-dispatcher-api.cabal new file mode 100644 index 0000000..e23a2c5 --- /dev/null +++ b/trace-dispatcher-api/trace-dispatcher-api.cabal @@ -0,0 +1,64 @@ +cabal-version: 3.0 + +name: trace-dispatcher-api +version: 0.1.0 +synopsis: Thin API layer for the trace-dispatcher tracing system +description: Core types (Trace, MetaTrace, LogFormatting) and combinators + (traceWith, contramapM, foldTraceM, routingTrace) that form the + stable API surface of the Hermod tracing system. Packages that + implement or consume tracers can depend on this package without + pulling in the full trace-dispatcher implementation. +category: System, + Logging, + Tracing, + Metrics, +copyright: 2020-2023 Input Output Global Inc (IOG), 2023-2026 Intersect. +author: Juergen Nicklisch, Michael Karg +maintainer: operations@iohk.io +license: Apache-2.0 +license-files: LICENSE + NOTICE + +common project-config + default-language: Haskell2010 + + default-extensions: LambdaCase + NamedFieldPuns + OverloadedStrings + + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wno-incomplete-patterns + + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial + + +library + import: project-config + hs-source-dirs: src + exposed-modules: Cardano.Logging.API + Cardano.Logging.Trace + Cardano.Logging.Trace.Combinators + Cardano.Logging.Types + Cardano.Logging.Types.Annotations + Cardano.Logging.Types.Config + Cardano.Logging.Types.Doc + + build-depends: base >=4.12 && <5 + , aeson >= 2.1.0.0 + , containers + , contra-tracer ^>= 0.2.1 + , deepseq + , hostname + , network + , serialise + , text + , unliftio + , unliftio-core diff --git a/trace-dispatcher/src/Cardano/Logging.hs b/trace-dispatcher/src/Cardano/Logging.hs index bffad88..afadd11 100644 --- a/trace-dispatcher/src/Cardano/Logging.hs +++ b/trace-dispatcher/src/Cardano/Logging.hs @@ -1,20 +1,48 @@ +-- | Batteries-included public interface for the Hermod tracing system. +-- +-- A typical application wires up tracing in three steps: +-- +-- 1. __Define trace types__: for each domain-specific message type, write +-- 'LogFormatting' (human\/machine rendering, metrics) and 'MetaTrace' +-- (namespace, severity, documentation) instances. +-- +-- 2. __Construct backends__: call 'mkCardanoTracer' (or 'mkCardanoTracer'') +-- with 'standardTracer', 'ekgTracer', and\/or 'forwardTracer' to build a +-- 'Trace IO YourType'. +-- +-- 3. __Configure__: load a 'TraceConfig' with 'readConfiguration' and apply it +-- with 'configureTracers'. Use 'checkTraceConfiguration' to validate the +-- config against all known namespaces at startup. +-- + module Cardano.Logging ( module X ) where -import Cardano.Logging.Configuration as X -import Cardano.Logging.ConfigurationParser as X -import Cardano.Logging.Consistency as X -import Cardano.Logging.Formatter as X -import Cardano.Logging.FrequencyLimiter as X +-- Core API types and combinators (from trace-dispatcher-api) +import Cardano.Logging.Types as X import Cardano.Logging.Trace as X -import Cardano.Logging.TraceDispatcherMessage as X + +-- Backend constructors import Cardano.Logging.Tracer.Composed as X import Cardano.Logging.Tracer.DataPoint as X import Cardano.Logging.Tracer.EKG as X import Cardano.Logging.Tracer.Forward as X import Cardano.Logging.Tracer.Standard as X -import Cardano.Logging.Types as X + +-- Configuration: loading, parsing, applying, and checking +import Cardano.Logging.Configuration as X +import Cardano.Logging.ConfigurationParser as X +import Cardano.Logging.Consistency as X +import Cardano.Logging.FrequencyLimiter as X + +-- Output types produced by the backend pipeline +-- (FormattedMessage, TraceObject, PreFormatted) +import Cardano.Logging.Formatter as X + +-- Utilities: showT, showTHex, showTReal, runInLoop import Cardano.Logging.Utils as X +-- Re-exports arrow/emit/squelch from contra-tracer for custom backend authors. +-- traceWith, contramapM, nullTracer, Tracer are shadowed by this package's own versions. import Control.Tracer as X hiding (Tracer, contramapM, nullTracer, traceWith) diff --git a/trace-dispatcher/src/Cardano/Logging/Configuration.hs b/trace-dispatcher/src/Cardano/Logging/Configuration.hs index 9502296..e22e2e9 100644 --- a/trace-dispatcher/src/Cardano/Logging/Configuration.hs +++ b/trace-dispatcher/src/Cardano/Logging/Configuration.hs @@ -24,6 +24,7 @@ module Cardano.Logging.Configuration ) where import Cardano.Logging.DocuGenerator (addFiltered, addLimiter, addSilent) +import Cardano.Logging.Formatter (FormattedMessage) import Cardano.Logging.FrequencyLimiter (limitFrequency) import Cardano.Logging.Trace import Cardano.Logging.TraceDispatcherMessage diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs index 9b4df4f..60f4073 100644 --- a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs +++ b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs @@ -26,6 +26,7 @@ module Cardano.Logging.DocuGenerator ( ) where import Cardano.Logging.ConfigurationParser () +import Cardano.Logging.Formatter (FormattedMessage) import Cardano.Logging.Types import Cardano.Logging.Types.DocuGenerator diff --git a/trace-dispatcher/src/Cardano/Logging/Formatter.hs b/trace-dispatcher/src/Cardano/Logging/Formatter.hs index 19e317d..ed8707c 100644 --- a/trace-dispatcher/src/Cardano/Logging/Formatter.hs +++ b/trace-dispatcher/src/Cardano/Logging/Formatter.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -5,7 +8,10 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Logging.Formatter ( - metricsFormatter + FormattedMessage(..) + , PreFormatted(..) + , TraceObject(..) + , metricsFormatter , preFormatted , forwardFormatter , forwardFormatter' @@ -21,7 +27,11 @@ import Cardano.Logging.Trace (contramapM) import Cardano.Logging.Types import Cardano.Logging.Types.TraceMessage -import Codec.Serialise (serialise) +import Codec.Serialise (Serialise (..), serialise) +import Control.DeepSeq (NFData) +import Data.ByteString (ByteString) +import Data.Time (UTCTime) +import GHC.Generics (Generic) import Control.Concurrent (myThreadId) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Control.Tracer as T @@ -41,6 +51,41 @@ import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) +data FormattedMessage = + FormattedHuman Bool Text + -- ^ The bool specifies if the formatting includes colours + | FormattedMachine Text + | FormattedMetrics [Metric] + | FormattedForwarder TraceObject + | FormattedCBOR ByteString + deriving stock (Eq, Show) + + +data PreFormatted = PreFormatted { + pfTime :: !UTCTime + , pfNamespace :: !Text + , pfThreadId :: !Text + , pfForHuman :: !(Maybe Text) + , pfForMachineObject :: AE.Object +} + +-- | Used as interface object for ForwarderTracer +data TraceObject = TraceObject { + toHuman :: !(Maybe Text) + , toMachine :: !Text + , toNamespace :: ![Text] + , toSeverity :: !SeverityS + , toDetails :: !DetailLevel + , toTimestamp :: !UTCTime + , toHostname :: !Text + , toThreadId :: !Text +} deriving stock + (Eq, Show, Generic) + -- ^ Instances for 'TraceObject' to forward it using 'trace-forward' library. + deriving anyclass + (Serialise, NFData) + + -- | If the @TRACE_DISPATCHER_LOGGING_HOSTNAME@ environment variable is set, -- it overrides the system hostname in the trace message. This is useful when -- multiple instances of a service or application on the same host. diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs deleted file mode 100644 index 869dda7..0000000 --- a/trace-dispatcher/src/Cardano/Logging/Trace.hs +++ /dev/null @@ -1,389 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Logging.Trace ( - traceWith - , withLoggingContext - - , filterTrace - , filterTraceMaybe - , filterTraceBySeverity - , filterTraceByPrivacy - - , setSeverity - , withSeverity - , privately - , setPrivacy - , withPrivacy - , allPublic - , allConfidential - , setDetails - , withDetails - - , contramapM - , contramapMCond - , contramapM' - , foldTraceM - , foldCondTraceM - , routingTrace - - , withNames - , appendPrefixName - , appendPrefixNames - , appendInnerName - , appendInnerNames - , withInnerNames - - , contramap' - , (>!$!<) - ) where - -import Cardano.Logging.Types - -import Control.Monad (forM_, join) -import Control.Monad.IO.Unlift -import qualified Control.Tracer as T -import Data.Functor.Contravariant as Contr (Contravariant, (>$<)) -import Data.Maybe (isJust) -import Data.Text (Text) - -import UnliftIO.MVar - --- | Adds a message object to a trace -traceWith :: Monad m => Trace m a -> a -> m () -traceWith (Trace tr) a = T.traceWith tr (emptyLoggingContext, Right a) - ---- | 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 -filterTrace ff (Trace tr) = Trace $ T.squelchUnless - (\case - (_lc, Left _) -> True - (lc, Right a) -> ff (lc, 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, Left _ctrl) -> True - (_lc, Right (Just _)) -> True - (_lc, Right Nothing) -> False) - (T.contramap - (\case - ( lc, Right (Just a)) -> (lc, Right a) - (_lc, Right Nothing) -> error "filterTraceMaybe: impossible" - ( lc, Left ctrl) -> (lc, Left ctrl)) - tr) - ---- | Only processes messages further a severity equal or greater as the ---- given one -filterTraceBySeverity :: Monad m - => Maybe SeverityF - -> Trace m a - -> Trace m a -filterTraceBySeverity (Just minSeverity) = - filterTrace - (\(lc, _) -> case lcSeverity lc of - Just s -> case minSeverity of - SeverityF (Just fs) -> s >= fs - SeverityF Nothing -> False - 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, cont) -> (lc, cont)) - tr - --- | Appends a name to the context. --- E.g. appendName "specific" $ appendName "middle" $ appendName "general" tracer --- give the result: `general.middle.specific`. -appendPrefixName :: Monad m => Text -> Trace m a -> Trace m a -appendPrefixName name (Trace tr) = Trace $ - T.contramap - (\ - (lc, cont) -> (lc {lcNSPrefix = name : lcNSPrefix lc}, cont)) - tr - -appendInnerName :: Monad m => Text -> Trace m a -> Trace m a -appendInnerName name (Trace tr) = Trace $ - T.contramap - (\ - (lc, cont) -> (lc {lcNSInner = name : lcNSInner lc}, cont)) - tr - --- | Appends all names to the context. -{-# INLINE appendPrefixNames #-} -appendPrefixNames :: Monad m => [Text] -> Trace m a -> Trace m a -appendPrefixNames names (Trace tr) = Trace $ - T.contramap - (\ - (lc, cont) -> (lc {lcNSPrefix = names ++ lcNSPrefix lc}, cont)) - tr - --- | Appends all names to the context. -appendInnerNames :: Monad m => [Text] -> Trace m a -> Trace m a -appendInnerNames names (Trace tr) = Trace $ - T.contramap - (\ - (lc, cont) -> (lc {lcNSInner = names ++ lcNSInner lc}, cont)) - tr - --- | Sets names for the messages in this trace based on the selector function -{-# INLINE withInnerNames #-} -withInnerNames :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a -withInnerNames (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right a) -> (lc {lcNSInner = nsInner (namespaceFor a)}, Right a) - (lc, Left c) -> (lc, Left c)) - tr - --- | Sets names for the messages in this trace based on the selector function --- and appends the provided names to the context. -{-# INLINE withNames #-} -withNames :: forall m a. (Monad m, MetaTrace a) => [Text] -> Trace m a -> Trace m a -withNames names (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right a) -> (lc {lcNSPrefix = names, - lcNSInner = nsInner (namespaceFor a)}, Right a) - (lc, Left c) -> (lc {lcNSPrefix = names}, Left c)) - 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, cont) -> if isJust (lcSeverity lc) - then (lc, cont) - else (lc {lcSeverity = Just s}, cont)) - tr - --- | Sets severities for the messages in this trace based on the MetaTrace class -{-# INLINE withSeverity #-} -withSeverity :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a -withSeverity (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right e) -> process lc (Right e) - (lc, Left c@(TCConfig _)) -> process lc (Left c) - (lc, Left d@(TCDocument _ _)) -> process lc (Left d) - (lc, Left e) -> (lc, Left e)) - tr - where - process lc cont@(Right v) = - if isJust (lcSeverity lc) - then (lc,cont) - else (lc {lcSeverity = severityFor (Namespace [] (lcNSInner lc) - :: Namespace a) (Just v)} , cont) - process lc cont@(Left _) = - if isJust (lcSeverity lc) - then (lc,cont) - else (lc {lcSeverity = severityFor (Namespace [] (lcNSInner lc) - :: Namespace a) Nothing}, cont) - ---- | 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 $ - \(lc, _cont) -> - case lcPrivacy lc 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, cont) -> if isJust (lcPrivacy lc) - then (lc, cont) - else (lc {lcPrivacy = Just p}, cont)) - tr - --- | Sets privacy for the messages in this trace based on the MetaTrace class -withPrivacy :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a -withPrivacy (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right e) -> process lc (Right e) - (lc, Left c@(TCConfig _)) -> process lc (Left c) - (lc, Left d@(TCDocument _ _)) -> process lc (Left d) - (lc, Left e) -> (lc, Left e)) - tr - where - process lc cont@(Right v) = - if isJust (lcPrivacy lc) - then (lc,cont) - else (lc {lcPrivacy = privacyFor (Namespace [] (lcNSInner lc) - :: Namespace a) (Just v)} , cont) - process lc cont@(Left _) = - if isJust (lcPrivacy lc) - then (lc,cont) - else (lc {lcPrivacy = privacyFor (Namespace [] (lcNSInner lc) - :: Namespace a) Nothing}, cont) - --- | 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, cont) -> if isJust (lcDetails lc) - then (lc, cont) - else (lc {lcDetails = Just p}, cont)) - tr - --- | Sets detail level for the messages in this trace based on the message -withDetails :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a -withDetails (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right e) -> process lc (Right e) - (lc, Left c@(TCConfig _)) -> process lc (Left c) - (lc, Left d@(TCDocument _ _)) -> process lc (Left d) - (lc, Left e) -> (lc, Left e)) - tr - where - process lc cont@(Right v) = - if isJust (lcDetails lc) - then (lc,cont) - else (lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc) - :: Namespace a) (Just v)} , cont) - process lc cont@(Left _) = - if isJust (lcDetails lc) - then (lc,cont) - else (lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc) - :: Namespace a) Nothing}, cont) - --- | Contramap a monadic function over a trace -{-# INLINE contramapM #-} -contramapM :: Monad m - => Trace m b - -> ((LoggingContext, Either TraceControl a) - -> m (LoggingContext, Either TraceControl b)) - -> m (Trace m a) -contramapM (Trace tr) mFunc = - pure $ Trace $ T.Tracer $ T.emit rFunc - where - rFunc arg = do - res <- mFunc arg - T.traceWith tr res - --- | Contramap a monadic function over a trace --- Can as well filter out messages -{-# INLINE contramapMCond #-} -contramapMCond :: Monad m - => Trace m b - -> ((LoggingContext, Either TraceControl a) - -> m (Maybe (LoggingContext, Either TraceControl b))) - -> m (Trace m a) -contramapMCond (Trace tr) mFunc = - pure $ Trace $ T.Tracer $ T.emit rFunc - where - rFunc arg = do - condMes <- mFunc arg - forM_ condMes (T.traceWith tr) - -{-# INLINE contramapM' #-} -contramapM' :: Monad m - => ((LoggingContext, Either TraceControl a) - -> m ()) - -> Trace m a -contramapM' rFunc = - Trace $ T.Tracer $ T.emit rFunc - --- | Folds the monadic cata function with acc over a. --- Uses an MVar to store the state -foldTraceM :: forall a acc m . (MonadUnliftIO m) - => (acc -> LoggingContext -> a -> m acc) - -> acc - -> Trace m (Folding a acc) - -> m (Trace m a) -foldTraceM cata initial (Trace tr) = do - ref <- liftIO (newMVar initial) - contramapM (Trace tr) - (\case - (lc, Right v) -> do - x' <- modifyMVar ref $ \x -> do - !accu <- cata x lc v - pure $ join (,) accu - pure (lc, Right (Folding x')) - (lc, Left control) -> do - pure (lc, Left control)) - --- | Like foldTraceM, but filter the trace by a predicate. -foldCondTraceM :: forall a acc m . (MonadUnliftIO m) - => (acc -> LoggingContext -> a -> m acc) - -> acc - -> (a -> Bool) - -> Trace m (Folding a acc) - -> m (Trace m a) -foldCondTraceM cata initial flt (Trace tr) = do - ref <- liftIO (newMVar initial) - contramapMCond (Trace tr) (foldF ref) - where - foldF ref = - \case - (lc, Right v) -> do - x' <- modifyMVar ref $ \x -> do - !accu <- cata x lc v - pure $ join (,) accu - if flt v - then pure $ Just (lc, Right (Folding x')) - else pure Nothing - (lc, Left control) -> do - pure $ Just (lc, Left control) - --- | 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 - -> Trace m a -routingTrace rf rc = contramapM' - (\case - (lc, Right a) -> do - nt <- rf a - T.traceWith (unpackTrace nt) (lc, Right a) - (lc, Left control) -> - T.traceWith (unpackTrace rc) (lc, Left control)) - --- | A contramap' which is strict in its second argument and its result captures --- a common pattern to avoid unintentionally leaking space when composing tracers. --- The infix alias is (>!$!<). -contramap', (>!$!<) :: Contravariant f => (a' -> a) -> (f a -> f a') - -contramap' a !b = - let !result = a Contr.>$< b - in result - -infixl 4 >!$!< - -(>!$!<) = contramap' diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs index d1748df..a8fff38 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs @@ -6,6 +6,7 @@ module Cardano.Logging.Tracer.EKG ( ) where import Cardano.Logging.DocuGenerator +import Cardano.Logging.Formatter (FormattedMessage (..)) import Cardano.Logging.Types import Cardano.Logging.Utils (showTReal, tryEvalNF) diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs index 8b122ed..e306e95 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs @@ -1,17 +1,88 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} module Cardano.Logging.Tracer.Forward - ( - forwardTracer + ( HowToConnect(..) + , Host + , Port + , forwardTracer ) where import Cardano.Logging.DocuGenerator +import Cardano.Logging.Formatter (FormattedMessage (..), TraceObject) import Cardano.Logging.Types +import Control.DeepSeq (NFData) import Control.Monad.IO.Class import qualified Control.Tracer as T +import qualified Data.Aeson as AE +import qualified Data.Aeson.Types as AE (Parser) +import Control.Applicative ((<|>)) +import Data.Kind (Type) +import Data.Text as T (Text, null, unpack, breakOnEnd, unsnoc) +import Data.Text.Read as T (decimal) +import Data.Word (Word16) +import GHC.Generics (Generic) + + +-- | Specifies how to connect to the peer. +-- +-- Taken from ekg-forward:System.Metrics.Configuration, to avoid dependency. +type Host :: Type +type Host = Text + +type Port :: Type +type Port = Word16 + +type HowToConnect :: Type +data HowToConnect + = LocalPipe !FilePath -- ^ Local pipe (UNIX or Windows). + | RemoteSocket !Host !Port -- ^ Remote socket (host and port). + deriving stock (Eq, Generic) + deriving anyclass (NFData) + +instance Show HowToConnect where + show = \case + LocalPipe pipe -> pipe + RemoteSocket host port -> T.unpack host ++ ":" ++ show port + +instance AE.ToJSON HowToConnect where + toJSON = AE.toJSON . show + toEncoding = AE.toEncoding . show + +-- first try to host:port, and if that fails revert to parsing any +-- string literal and assume it is a localpipe. +instance AE.FromJSON HowToConnect where + parseJSON = AE.withText "HowToConnect" $ \t -> + (uncurry RemoteSocket <$> parseHostPort t) + <|> ( LocalPipe <$> parseLocalPipe t) + +parseLocalPipe :: Text -> AE.Parser FilePath +parseLocalPipe t + | T.null t = fail "parseLocalPipe: empty Text" + | otherwise = pure $ T.unpack t + +parseHostPort :: Text -> AE.Parser (Text, Word16) +parseHostPort t + | T.null t + = fail "parseHostPort: empty Text" + | otherwise + = let + (host_, portText) = T.breakOnEnd ":" t + host = maybe "" fst (T.unsnoc host_) + in if + | T.null host -> fail "parseHostPort: Empty host or no colon found." + | T.null portText -> fail "parseHostPort: Empty port." + | Right (port, remainder) <- T.decimal portText + , T.null remainder + , 0 <= port, port <= 65535 -> pure (host, port) + | otherwise -> fail "parseHostPort: Non-numeric port or value out of range." --------------------------------------------------------------------------- diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs index 328306d..6459336 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs @@ -6,6 +6,7 @@ module Cardano.Logging.Tracer.Standard ( ) where import Cardano.Logging.DocuGenerator +import Cardano.Logging.Formatter (FormattedMessage (..)) import Cardano.Logging.Types import Cardano.Logging.Utils (threadLabelMe, tryEvalNF) diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs deleted file mode 100644 index 3ef3ed0..0000000 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ /dev/null @@ -1,667 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} - -{-# OPTIONS_GHC -Wno-partial-fields #-} - -module Cardano.Logging.Types ( - Trace(..) - , LogFormatting(..) - , Metric(..) - , getMetricName - , LoggingContext(..) - , emptyLoggingContext - , Namespace(..) - , nsReplacePrefix - , nsReplaceInner - , nsCast - , nsPrependInner - , nsGetComplete - , nsGetTuple - , nsRawToText - , nsToText - , MetaTrace(..) - , DetailLevel(..) - , Privacy(..) - , SeverityS(..) - , SeverityF(..) - , ConfigOption(..) - , ForwarderAddr(..) - , FormatLogging(..) - , ForwarderMode(..) - , Verbosity(..) - , TraceOptionForwarder(..) - , defaultForwarder - , PrometheusSimpleRun(..) - , prometheusSimpleNoOverrides - , ConfigReflection(..) - , emptyConfigReflection - , TraceConfig(..) - , emptyTraceConfig - , FormattedMessage(..) - , TraceControl(..) - , DocCollector(..) - , LogDoc(..) - , emptyLogDoc - , BackendConfig(..) - , Folding(..) - , unfold - , TraceObject(..) - , PreFormatted(..) - , HowToConnect(..) -) where - -import Codec.Serialise (Serialise (..)) -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData) -import qualified Control.Tracer as T -import qualified Data.Aeson as AE -import qualified Data.Aeson.Types as AE (Parser) -import Data.Bool (bool) -import Data.ByteString (ByteString) -import Data.IORef -import Data.Kind (Type) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text as T (Text, breakOnEnd, intercalate, null, - pack, singleton, unpack, unsnoc, - words) -import Data.Text.Read as T (decimal) -import Data.Time (UTCTime) -import Data.Word (Word16) -import GHC.Generics -import Network.HostName (HostName) -import Network.Socket (PortNumber) - - --- | 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 :: T.Tracer m (LoggingContext, Either TraceControl a)} - --- | Contramap lifted to Trace -instance Monad m => T.Contravariant (Trace m) where - contramap f (Trace tr) = Trace $ - T.contramap (\case - (lc, Right a) -> (lc, Right (f a)) - (lc, Left tc) -> (lc, Left tc)) - 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 - --- | A unique identifier for every message, composed of text --- A namespace can as well appear with the tracer name (e.g. "ChainDB.OpenEvent.OpenedDB"), --- or more prefixes, in this moment it is a NamespaceOuter is used -data Namespace a = Namespace { - nsPrefix :: [Text] - , nsInner :: [Text]} - deriving stock Eq - -instance Show (Namespace a) where - show (Namespace [] []) = "emptyNS" - show (Namespace [] nsInner') = - unpack $ intercalate (singleton '.') nsInner' - show (Namespace nsPrefix' nsInner') = - unpack $ intercalate (singleton '.') (nsPrefix' ++ nsInner') - -nsReplacePrefix :: [Text] -> Namespace a -> Namespace a -nsReplacePrefix o (Namespace _ i) = Namespace o i - -nsReplaceInner :: [Text] -> Namespace a -> Namespace a -nsReplaceInner i (Namespace o _) = Namespace o i - - -nsPrependInner :: Text -> Namespace a -> Namespace b -nsPrependInner t (Namespace o i) = Namespace o (t : i) - -{-# INLINE nsCast #-} -nsCast :: Namespace a -> Namespace b -nsCast (Namespace o i) = Namespace o i - -nsGetComplete :: Namespace a -> [Text] -nsGetComplete (Namespace [] i) = i -nsGetComplete (Namespace o i) = o ++ i - -nsGetTuple :: Namespace a -> ([Text],[Text]) -nsGetTuple (Namespace o i) = (o,i) - -nsRawToText :: ([Text], [Text]) -> Text -nsRawToText = nsToText . uncurry Namespace - -nsToText :: Namespace a -> Text -nsToText (Namespace ns1 ns2) = intercalate "." (ns1 ++ ns2) - --- | Every message needs this to define how to represent itself -class LogFormatting a where - -- | Machine readable representation with the possibility to represent with varying serialisations based on the detail level. - -- This will result in JSON formatted log output. - -- A @forMachine@ implementation is required for any instance definition. - forMachine :: DetailLevel -> a -> AE.Object - - -- | Human-readable representation. - -- The empty text indicates there's no specific human-readable formatting for that type - this is the default implementation. - -- - -- If however human-readble output is explicitly requested, e.g. by logs, the system will fall back to a JSON object - -- conforming to the @forMachine@ definition, and rendering it as a value in /{"data": }`/ - -- Leaving out @forHuman@ in some instance definition will not lead to loss of log information that way. - forHuman :: a -> Text - forHuman _v = "" - - -- | Metrics representation. - -- The default indicates that no metric is based on trace occurrences of that type. - asMetrics :: a -> [Metric] - asMetrics _v = [] - - -class MetaTrace a where - namespaceFor :: a -> Namespace a - - severityFor :: Namespace a -> Maybe a -> Maybe SeverityS - privacyFor :: Namespace a -> Maybe a -> Maybe Privacy - privacyFor _ _ = Just Public - detailsFor :: Namespace a -> Maybe a -> Maybe DetailLevel - detailsFor _ _ = Just DNormal - - documentFor :: Namespace a -> Maybe Text - metricsDocFor :: Namespace a -> [(Text,Text)] - metricsDocFor _ = [] - allNamespaces :: [Namespace a] - --- | This type defines metrics, and how to update them. --- --- The @Text@ field always contains the metric name. --- Metric names are recommended to conform to the [Prometheus data model](https://prometheus.io/docs/concepts/data_model/#metric-names-and-labels). --- If you want to structure your metrics in namespaces, please use a dot separator, such as @"name.space.metricName"@. --- --- Example, defining three metrics based on the occurrence of a single trace event: --- --- > data Trace = BatchProcessed { batchSize :: Int } --- > --- > instance LogFormatting Trace where --- > asMetrics (BatchProcessed size) = --- > [ IntM "batch.current" (fromIntegral size) -- element count of the most recent batch --- > , CounterM "batchesTotal" Nothing -- total batches processed (increment by 1) --- > , CounterM "batch.total" (Just $ fromIntegral size) -- total elements processed --- > ] --- -data Metric - -- | An integer gauge metric. - -- Gauges are variable values. - = IntM Text Integer - -- | A floating-point gauge metric. - -- Gauges are variable values. - | DoubleM Text Double - -- | A counter metric. - -- Counters are non-negative, monotonically increasing values. - | CounterM Text (Maybe Int) - -- | A label set containing the specified key-value pairs. - -- The OpenMetrics standard permits empty label sets; the value of this labeled metric will always be "1". - -- - -- For instance, a @PrometheusM "foo" [("key1", "value1"), ("key2", "value2")]@ - -- will be exposed as /"foo{key1=\"value1\",key2=\"value2\"} 1"/ - | PrometheusM Text [(Text, Text)] - deriving stock (Eq, Show, Generic) - deriving anyclass NFData - - -getMetricName :: Metric -> Text -getMetricName (IntM name _) = name -getMetricName (DoubleM name _) = name -getMetricName (CounterM name _) = name -getMetricName (PrometheusM name _) = name - - --- | Context any log message carries -data LoggingContext = LoggingContext { - lcNSInner :: [Text] - , lcNSPrefix :: [Text] - , lcSeverity :: Maybe SeverityS - , lcPrivacy :: Maybe Privacy - , lcDetails :: Maybe DetailLevel - } - deriving stock - (Show, Generic) - deriving anyclass - Serialise - -emptyLoggingContext :: LoggingContext -emptyLoggingContext = LoggingContext [] [] Nothing Nothing Nothing - --- | The detail level facilitates rendering the same trace value to messages with varying verbosities in its @instance LogFormatting@. -data DetailLevel = - DMinimal - | DNormal - | DDetailed - | DMaximum - deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) - deriving anyclass (Serialise, AE.FromJSON, NFData) - -instance AE.ToJSON DetailLevel where - toEncoding = AE.genericToEncoding AE.defaultOptions - --- | Privacy of a message. Default is Public -data Privacy = - Confidential -- ^ confidential information - handle with care - | Public -- ^ can be public. - deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) - deriving anyclass Serialise - --- | Severity of a message. These are defined alongside message namespaces in an @instance MetaTrace@. --- --- The severities and their semantics adhere to those defined in the [Syslog Protocol](https://www.rfc-editor.org/rfc/rfc5424#section-6.2.1). -data SeverityS - = Debug -- ^ Debug messages - | Info -- ^ Informational - confirmation the program is working as expected - | Notice -- ^ Normal, but significant conditions - may require special handling - | Warning -- ^ General Warnings - | Error -- ^ General Errors - | Critical -- ^ Severe situations - | Alert -- ^ Take immediate action - | Emergency -- ^ System is unusable - deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Generic) - deriving anyclass (AE.ToJSON, AE.FromJSON, Serialise, NFData) - --- | Severity for a filter. These are supplied by a concrete configuration of how to filter the entire message namespace at runtime. --- --- @Nothing@ means: filter everything ('Silence'). --- --- @Just severity@ means: render messages with @SeverityS >= severity@. -newtype SeverityF = SeverityF (Maybe SeverityS) - deriving stock 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 - 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 "Silence") = pure (SeverityF Nothing) - parseJSON invalid = fail $ "Parsing of filter Severity failed." - <> "Unknown severity: " <> show invalid - -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" - - ----------------------------------------------------------------- --- Configuration - --- | -data ConfigReflection = ConfigReflection { - crSilent :: IORef (Set [Text]) - , crNoMetrics :: IORef (Set [Text]) - , crAllTracers :: IORef (Set [Text]) - } - -emptyConfigReflection :: IO ConfigReflection -emptyConfigReflection = do - silence <- newIORef Set.empty - hasMetrics <- newIORef Set.empty - allTracers <- newIORef Set.empty - pure $ ConfigReflection silence hasMetrics allTracers - -data FormattedMessage = - FormattedHuman Bool Text - -- ^ The bool specifies if the formatting includes colours - | FormattedMachine Text - | FormattedMetrics [Metric] - | FormattedForwarder TraceObject - | FormattedCBOR ByteString - deriving stock (Eq, Show) - - -data PreFormatted = PreFormatted { - pfTime :: !UTCTime - , pfNamespace :: !Text - , pfThreadId :: !Text - , pfForHuman :: !(Maybe Text) - , pfForMachineObject :: AE.Object -} - --- | Used as interface object for ForwarderTracer -data TraceObject = TraceObject { - toHuman :: !(Maybe Text) - , toMachine :: !Text - , toNamespace :: ![Text] - , toSeverity :: !SeverityS - , toDetails :: !DetailLevel - , toTimestamp :: !UTCTime - , toHostname :: !Text - , toThreadId :: !Text -} deriving stock - (Eq, Show, Generic) - -- ^ Instances for 'TraceObject' to forward it using 'trace-forward' library. - deriving anyclass - (Serialise, NFData) - --- | -data BackendConfig = - Forwarder - | Stdout FormatLogging - | EKGBackend - | DatapointBackend - | PrometheusSimple Bool (Maybe HostName) PortNumber -- boolean: drop suffixes like "_int" in exposition; default: False - deriving stock (Eq, Ord, Show, Generic) - -instance AE.ToJSON BackendConfig where - toJSON Forwarder = AE.String "Forwarder" - toJSON DatapointBackend = AE.String "DatapointBackend" - toJSON EKGBackend = AE.String "EKGBackend" - toJSON (Stdout f) = AE.String $ "Stdout " <> (pack . show) f - toJSON (PrometheusSimple s h p) = AE.String $ "PrometheusSimple " - <> bool mempty "nosuffix" s - <> maybe mempty ((<> " ") . pack) h - <> (pack . show) p - -instance AE.FromJSON BackendConfig where - parseJSON = AE.withText "BackendConfig" $ \case - "Forwarder" -> pure Forwarder - "EKGBackend" -> pure EKGBackend - "DatapointBackend" -> pure DatapointBackend - "Stdout HumanFormatColoured" -> pure $ Stdout HumanFormatColoured - "Stdout HumanFormatUncoloured" -> pure $ Stdout HumanFormatUncoloured - "Stdout MachineFormat" -> pure $ Stdout MachineFormat - prometheus -> either fail pure (parsePrometheusString prometheus) - -parsePrometheusString :: Text -> Either String BackendConfig -parsePrometheusString t = case T.words t of - ["PrometheusSimple", portNo_] -> - parsePort portNo_ >>= Right . PrometheusSimple False Nothing - ["PrometheusSimple", arg, portNo_] -> - parsePort portNo_ >>= Right . if validSuffix arg then PrometheusSimple (isNoSuffix arg) Nothing else PrometheusSimple False (Just $ unpack arg) - ["PrometheusSimple", noSuff, host, portNo_] - | validSuffix noSuff -> parsePort portNo_ >>= Right . PrometheusSimple (isNoSuffix noSuff) (Just $ unpack host) - | otherwise -> Left $ "invalid modifier for PrometheusSimple: " ++ show noSuff - _ - -> Left $ "unknown backend: " ++ show t - where - validSuffix s = s == "suffix" || s == "nosuffix" - isNoSuffix = (== "nosuffix") - parsePort p = case T.decimal p of - Right (portNo :: Word, rest) - | T.null rest && 0 < portNo && portNo < 65536 -> Right $ fromIntegral portNo - _ -> failure - where failure = Left $ "invalid PrometheusSimple port: " ++ show p - -data FormatLogging = - HumanFormatColoured - | HumanFormatUncoloured - | MachineFormat - deriving stock (Eq, Ord, Show) - --- Configuration options for individual namespace elements -data ConfigOption = - -- | Severity level for a filter (default is Warning) - ConfSeverity {severity :: SeverityF} - -- | Detail level (default is DNormal) - | ConfDetail {detail :: DetailLevel} - -- | To which backend to pass - -- Default is [EKGBackend, Forwarder, Stdout MachineFormat] - | ConfBackend {backends :: [BackendConfig]} - -- | Construct a limiter with limiting to the Double, - -- which represents frequency in number of messages per second - | ConfLimiter {maxFrequency :: Double} - deriving stock (Eq, Ord, Show, Generic) - -newtype ForwarderAddr - = LocalSocket FilePath - deriving stock (Eq, Ord, Show) - -instance AE.FromJSON ForwarderAddr where - parseJSON = AE.withObject "ForwarderAddr" $ \o -> LocalSocket <$> o AE..: "filePath" - -data ForwarderMode = - -- | Forwarder works as a client: it initiates network connection with - -- 'cardano-tracer' and/or another Haskell acceptor application. - Initiator - -- | Forwarder works as a server: it accepts network connection from - -- 'cardano-tracer' and/or another Haskell acceptor application. - | Responder - deriving stock (Eq, Ord, Show, Generic) - -data Verbosity = - -- | Maximum verbosity for all tracers in the forwarding protocols. - Maximum - -- | Minimum verbosity, the forwarding will work as silently as possible. - | Minimum - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass AE.ToJSON - -instance AE.FromJSON Verbosity where - parseJSON (AE.String "Maximum") = pure Maximum - parseJSON (AE.String "Minimum") = pure Minimum - parseJSON other = fail $ "Parsing of Verbosity failed." - <> "Unknown Verbosity: " <> show other - -data TraceOptionForwarder = TraceOptionForwarder { - tofQueueSize :: Word - , tofVerbosity :: Verbosity - , tofMaxReconnectDelay :: Word -} deriving stock (Eq, Ord, Show, Generic) - --- A word regarding queue size: --- --- In case of a missing forwarding service consumer, traces messages will be --- buffered. This mitigates short forwarding interruptions, or delays at startup --- time. --- --- The queue capacity should thus correlate to the expected log lines per second --- given a particular tracing configuration - to avoid unnecessarily increasing --- memory footprint. --- --- The default values here are chosen to accomodate verbose tracing output --- (i.e., buffering 1min worth of trace data given ~32 messages per second). A --- config that results in less than 5 msgs per second should also provide --- `TraceOptionForwarder` a queue size value considerably lower. --- --- The queue size ties in with the max number of trace objects cardano-tracer --- requests periodically, the default for that being 100. Here, the queue can --- hold enough traces for 10 subsequent polls by cardano-tracer. -instance AE.FromJSON TraceOptionForwarder where - parseJSON = AE.withObject "TraceOptionForwarder" $ \obj -> do - -- Field "queueSize" is the new field that replaces and unifies - -- both "connQueueSize" and "disconnQueueSize". - maybeQueueSize <- obj AE..:? "queueSize" - queueSize <- case maybeQueueSize of - -- If the new field was provided we use it. - (Just qs) -> return qs - -- Else we look for the deprecated fields. - Nothing -> do - connQueueSize <- obj AE..:? "connQueueSize" AE..!= 128 - disconnQueueSize <- obj AE..:? "disconnQueueSize" AE..!= 192 - return $ max connQueueSize disconnQueueSize - verbosity <- obj AE..:? "verbosity" AE..!= Minimum - maxReconnectDelay <- obj AE..:? "maxReconnectDelay" AE..!= 45 - return $ TraceOptionForwarder queueSize verbosity maxReconnectDelay - -instance AE.ToJSON TraceOptionForwarder where - toJSON TraceOptionForwarder{..} = AE.object - [ - "queueSize" AE..= tofQueueSize, - "verbosity" AE..= tofVerbosity, - "maxReconnectDelay" AE..= tofMaxReconnectDelay - ] - -defaultForwarder :: TraceOptionForwarder -defaultForwarder = TraceOptionForwarder { - tofQueueSize = 192 - , tofVerbosity = Minimum - , tofMaxReconnectDelay = 45 -} - -instance AE.FromJSON ForwarderMode where - parseJSON (AE.String "Initiator") = pure Initiator - parseJSON (AE.String "Responder") = pure Responder - parseJSON other = fail $ "Parsing of ForwarderMode failed." - <> "Unknown ForwarderMode: " <> show other - -data PrometheusSimpleRun - = -- | Parameter overrides for PrometheusSimple DoS protection - PrometheusSimpleRun - { connTimeout :: Maybe Word -- ^ Release socket after inactivity (seconds); default: 22 - , connCountGlobal :: Maybe Word -- ^ Limit total number of incoming connections; default: 16 - , connCountPerHost :: Maybe Word -- ^ Limit number of incoming connections from the same host; default: 5 - , connPerSecond :: Maybe Double -- ^ Limit requests per second (may be < 1.0); default: 8.0 - } - deriving (Show, Generic, AE.FromJSON, AE.ToJSON) - -prometheusSimpleNoOverrides :: PrometheusSimpleRun -prometheusSimpleNoOverrides = PrometheusSimpleRun Nothing Nothing Nothing Nothing - -data TraceConfig = TraceConfig { - -- | Options specific to a certain namespace - tcOptions :: Map.Map [Text] [ConfigOption] - -- | Options for the forwarder - , tcForwarder :: Maybe TraceOptionForwarder - -- | Optional human-readable name of the node. - , tcNodeName :: Maybe Text - -- | Optional prefix for metrics. - , tcMetricsPrefix :: Maybe Text - -- | Optional resource trace frequency in milliseconds. - , tcResourceFrequency :: Maybe Int - -- | Optional ledger metrics frequency in milliseconds. - , tcLedgerMetricsFrequency :: Maybe Int - -- | Optional parameter overrides for PrometheusSimple DoS protection - , tcPrometheusSimpleRun :: Maybe PrometheusSimpleRun - } - deriving stock Show - -emptyTraceConfig :: TraceConfig -emptyTraceConfig = TraceConfig { - tcOptions = Map.empty - , tcForwarder = Nothing - , tcNodeName = Nothing - , tcMetricsPrefix = Nothing - , tcResourceFrequency = Nothing - , tcLedgerMetricsFrequency = Nothing - , tcPrometheusSimpleRun = Nothing - } - ---------------------------------------------------------------------------- --- Control and Documentation - --- | When configuring a net of tracers, it should be run with Config on all --- entry points first, and then with TCOptimize. When reconfiguring it needs to --- run TCReset followed by Config followed by TCOptimize -data TraceControl where - TCReset :: TraceControl - TCConfig :: TraceConfig -> TraceControl - TCOptimize :: ConfigReflection -> TraceControl - TCDocument :: Int -> DocCollector -> TraceControl - -newtype DocCollector = DocCollector (IORef (Map Int LogDoc)) - -data LogDoc = LogDoc { - ldDoc :: !Text - , ldMetricsDoc :: !(Map.Map Text Text) - , ldNamespace :: ![([Text],[Text])] - , ldSeverityCoded :: !(Maybe SeverityS) - , ldPrivacyCoded :: !(Maybe Privacy) - , ldDetailsCoded :: !(Maybe DetailLevel) - , ldDetails :: ![DetailLevel] - , ldBackends :: ![BackendConfig] - , ldFiltered :: ![SeverityF] - , ldLimiter :: ![(Text, Double)] - , ldSilent :: Bool -} deriving stock (Eq, Show) - -emptyLogDoc :: Text -> [(Text, Text)] -> LogDoc -emptyLogDoc d m = LogDoc d (Map.fromList m) [] Nothing Nothing Nothing [] [] [] [] False - --- | Type for the function foldTraceM from module Cardano/Logging/Trace -newtype Folding a b = Folding b - -unfold :: Folding a b -> b -unfold (Folding b) = b - -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 - --- | Specifies how to connect to the peer. --- --- Taken from ekg-forward:System.Metrics.Configuration, to avoid dependency. -type Host :: Type -type Host = Text - -type Port :: Type -type Port = Word16 - -type HowToConnect :: Type -data HowToConnect - = LocalPipe !FilePath -- ^ Local pipe (UNIX or Windows). - | RemoteSocket !Host !Port -- ^ Remote socket (host and port). - deriving stock (Eq, Generic) - deriving anyclass (NFData) - -instance Show HowToConnect where - show = \case - LocalPipe pipe -> pipe - RemoteSocket host port -> T.unpack host ++ ":" ++ show port - -instance AE.ToJSON HowToConnect where - toJSON = AE.toJSON . show - toEncoding = AE.toEncoding . show - --- first try to host:port, and if that fails revert to parsing any --- string literal and assume it is a localpipe. -instance AE.FromJSON HowToConnect where - parseJSON = AE.withText "HowToConnect" $ \t -> - (uncurry RemoteSocket <$> parseHostPort t) - <|> ( LocalPipe <$> parseLocalPipe t) - -parseLocalPipe :: Text -> AE.Parser FilePath -parseLocalPipe t - | T.null t = fail "parseLocalPipe: empty Text" - | otherwise = pure $ T.unpack t - -parseHostPort :: Text -> AE.Parser (Text, Word16) -parseHostPort t - | T.null t - = fail "parseHostPort: empty Text" - | otherwise - = let - (host_, portText) = T.breakOnEnd ":" t - host = maybe "" fst (T.unsnoc host_) - in if - | T.null host -> fail "parseHostPort: Empty host or no colon found." - | T.null portText -> fail "parseHostPort: Empty port." - | Right (port, remainder) <- T.decimal portText - , T.null remainder - , 0 <= port, port <= 65535 -> pure (host, port) - | otherwise -> fail "parseHostPort: Non-numeric port or value out of range." diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal index 3e8871e..6108199 100644 --- a/trace-dispatcher/trace-dispatcher.cabal +++ b/trace-dispatcher/trace-dispatcher.cabal @@ -53,14 +53,12 @@ library Cardano.Logging.Prometheus.Exposition Cardano.Logging.Prometheus.NetworkRun Cardano.Logging.Prometheus.TCPServer - Cardano.Logging.Trace Cardano.Logging.TraceDispatcherMessage Cardano.Logging.Tracer.DataPoint Cardano.Logging.Tracer.EKG Cardano.Logging.Tracer.Standard Cardano.Logging.Tracer.Forward Cardano.Logging.Tracer.Composed - Cardano.Logging.Types Cardano.Logging.Types.NodeInfo Cardano.Logging.Types.NodeStartupInfo Cardano.Logging.Types.TraceMessage @@ -69,6 +67,7 @@ library other-modules: Cardano.Logging.Types.DocuGenerator build-depends: base >=4.12 && <5 + , trace-dispatcher-api , aeson >= 2.1.0.0 , aeson-pretty , async