diff --git a/changelog.d/20260908_120000_javier.sagredo_tracing_sublibrary.md b/changelog.d/20260908_120000_javier.sagredo_tracing_sublibrary.md new file mode 100644 index 0000000000..b9b4817b6e --- /dev/null +++ b/changelog.d/20260908_120000_javier.sagredo_tracing_sublibrary.md @@ -0,0 +1,32 @@ +### Non-Breaking + +- Added a new public sublibrary `ouroboros-consensus:tracing`, holding the + `LogFormatting` and `MetaTrace` instances for Consensus types. These were in + `cardano-node`, and now live next to the types they describe, so that a change + to a traced type and the change to its rendering land in the same commit. + + The sublibrary also exports `Ouroboros.Consensus.Tracing.HasIssuer`, the + `HasIssuer` class and its instances, and `Ouroboros.Consensus.Tracing.KESInfo`, + moved over from `cardano-node` for the same reason. + + Compared to the instances in `cardano-node`: + + - At `DDetailed`, the `tx` field of a transaction is now the hex-encoded CBOR + of the transaction instead of its `Show` rendering. For Shelley-based eras + this is the ledger `Tx` serialised at the era's protocol version, which + reproduces the received bytes of the body, witnesses and auxiliary data. For + Byron it is the annotated bytes of the mempool payload, which are its + canonical encoding. This affects every mempool trace that carries a + transaction. + - `TraceMempoolRejectedTx` now includes `errdetails`, the source of the + rejection, at every detail level, not only at `DDetailed`. + - `Point` and `RealPoint` now have a `forHuman` rendering, " at slot + ". + - `Ouroboros.Consensus.Tracing.Render` no longer exports `renderTip`, + `renderTipForDetails` or `renderSlotNo`, which no instance used, nor + re-exports `showT`, which is available from `Cardano.Logging`. + - Fixed `MetaTrace` delegation to nested namespaces. The LSM backend + namespaces under `LedgerEvent.Flavor.V2.BackendTrace` are now documented, + and the privacy and detail level of `AddBlockEvent.AddBlockValidation`, + `ImmDbEvent.ChunkValidation` and `ImmDbEvent.CacheEvent` namespaces are now + taken from the nested tracer instead of the default. diff --git a/golden/tracing/era-shelley-render.golden b/golden/tracing/era-shelley-render.golden new file mode 100644 index 0000000000..bcc03f70d4 --- /dev/null +++ b/golden/tracing/era-shelley-render.golden @@ -0,0 +1,23 @@ +renderScriptHash = 4d50a11e297e7783383bf06dd6e4e481230323bd96cd8b8d9ee3888d +renderScriptIntegrityHash Nothing = null +renderScriptIntegrityHash (Just _) = "31237cdb79ae1dfa7ffb87cde7ea8a80352d300ee5ac758a6cddd19d671925ec" +renderRewardAccount mainnet/key = stake1u9r87kyn9d2fzpvy5r5w5fdzyhsx59znpvhfd6fcc5ar7gs7uwm3p +renderRewardAccount testnet/key = stake_test1upr87kyn9d2fzpvy5r5w5fdzyhsx59znpvhfd6fcc5ar7gsekye4u +renderRewardAccount mainnet/script = stake17x85vx25lch33lhpmj3r8u6cjplxg0lc88k3lx27f0ejtcc83spxq +renderTxIn = 8928aae63c84d87ea098564d1e03ad813f107add474e56aedd286349c0c03ea4#0 +renderScriptIndex spending = {"kind":"ScriptWitnessIndexTxIn","value":0} +renderScriptIndex minting = {"kind":"ScriptWitnessIndexMint","value":1} +renderScriptIndex certifying = {"kind":"ScriptWitnessIndexCertificate","value":2} +renderScriptIndex withdrawing = {"kind":"ScriptWitnessIndexWithdrawal","value":3} +renderScriptIndex voting = {"kind":"ScriptWitnessIndexVoting","value":4} +renderScriptIndex proposing = {"kind":"ScriptWitnessIndexProposing","value":5} +renderScriptPurpose spending = {"spending":"8928aae63c84d87ea098564d1e03ad813f107add474e56aedd286349c0c03ea4#0"} +renderScriptPurpose minting = {"minting":{"item":"2db8410d969b6ad6b6969703c77ebf6c44061aa51c5d6ceba46557e2"}} +renderScriptPurpose certifying = {"certifying":{"item":{"credential":{"keyHash":"dea21a2507d38c552e24df8c4d722e81e1e63de8755d808925deaf9d"},"deposit":null,"kind":"RegCert"}}} +renderScriptPurpose withdrawing = {"rewarding":"stake1uyg94rcmk4jyfjkvscmce92zrt8wkvntp7mhg0jf86uzl4gynahcu"} +renderScriptPurpose voting = {"voting":{"item":{"contents":"8761dc36fca24f0f3d78ae5a6c2787af7730a9e9eafdc250eb1fffb1","tag":"StakePoolVoter"}}} +renderScriptPurpose proposing = {"proposing":{"item":{"anchor":{"dataHash":"8d234302aeb06f2a7effb905e43f037e4dca1c2a0f050e82175328c5ce8d31f4","url":"https://example.com"},"deposit":1000,"govAction":{"tag":"InfoAction"},"returnAddr":{"credential":{"keyHash":"4752e70e4f651479d186955c57142dae87b279ff2c77ef5720af7282"},"network":"Mainnet"}}}} +renderScriptIndex guarding = {"kind":"ScriptWitnessIndexGuarding","value":6} +renderScriptPurpose guarding = {"guarding":"d1b3884173424c627f4bac9957ef28b8027dcd13f560c42088aa1fbf"} +renderMissingRedeemers = {"245d5a7a06fe18358242e81281cd5ba9e6abe4efc54e7b659f25abae":{"spending":"8928aae63c84d87ea098564d1e03ad813f107add474e56aedd286349c0c03ea4#0"},"b0c53e2bf180858da4b64eb5598c5615bba7d723d2b604a83b7f9165":{"minting":{"item":"4a1c412d8e2b3015a7fb7d382808fb7cb721bf93a56e8bb6661cdebe"}}} +renderIncompleteWithdrawals = {"stake1uykhy5fggpkusvhtwnz8pxk2q5fynxeu0vt7qrtuktndrvgxnyhra":"Mismatch (RelEQ) {supplied: 1, expected: 2}"} diff --git a/nix/haskell.nix b/nix/haskell.nix index 1d4d314d0a..af2ce9f028 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -13,11 +13,13 @@ let ../NOTICE ../cabal ../cabal.project + ../golden ../ouroboros-consensus ../ouroboros-consensus-cardano ../ouroboros-consensus-diffusion ../ouroboros-consensus-protocol ../ouroboros-consensus.cabal + ../tracing ]; }; forAllProjectPackages = cfg: args@{ config, lib, ... }: { @@ -64,13 +66,21 @@ let packages.cardano-ledger-dijkstra.components.library.doHaddock = false; packages.cardano-ledger-mary.components.library.doHaddock = false; packages.cardano-ledger-shelley.components.library.doHaddock = false; - # Options related to tasty and tasty-golden: - packages.ouroboros-consensus.components.tests = - lib.listToAttrs (map - (n: lib.nameValuePair "${n}-test" { - testFlags = lib.mkForce [ "--no-create --hide-successes" ]; - extraSrcFiles = [ "ouroboros-consensus-cardano/golden/${n}/**/*" ]; - }) [ "byron" "shelley" "cardano" ]); + # Options related to tasty and tasty-golden. The golden files live + # outside their test component's hs-source-dirs, so each one has to be + # listed here; otherwise haskell.nix prunes it out of the component + # source and tasty-golden creates it and passes instead of comparing. + packages.ouroboros-consensus.components.tests = lib.mapAttrs + (_: golden: { + testFlags = lib.mkForce [ "--no-create --hide-successes" ]; + extraSrcFiles = [ "${golden}/**/*" ]; + }) + { + byron-test = "ouroboros-consensus-cardano/golden/byron"; + shelley-test = "ouroboros-consensus-cardano/golden/shelley"; + cardano-test = "ouroboros-consensus-cardano/golden/cardano"; + tracing-test = "golden/tracing"; + }; } ({ pkgs, lib, ... }: lib.mkIf pkgs.stdenv.hostPlatform.isWindows { # https://github.com/input-output-hk/haskell.nix/issues/2332 diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index 615309de28..fe6b38bfac 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs @@ -16,6 +16,7 @@ module Ouroboros.Consensus.Node.Tracers , TraceForgeEvent (..) , TraceLabelCreds (..) , TracePerasCertInclusionEvent (..) + , TracePerasVoteForgingEvent (..) ) where import Control.Exception (SomeException) @@ -50,7 +51,7 @@ import Ouroboros.Consensus.Node.GSM (TraceGsmEvent) import Ouroboros.Consensus.Peras.Cert.Inclusion.Trace ( TracePerasCertInclusionEvent (..) ) -import Ouroboros.Consensus.Peras.Voting.Trace (TracePerasVoteForgingEvent) +import Ouroboros.Consensus.Peras.Voting.Trace (TracePerasVoteForgingEvent (..)) import Ouroboros.Consensus.Protocol.Praos.AgentClient ( KESAgentClientTrace (..) ) diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 94fb246993..2dbd695a43 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -422,6 +422,95 @@ library directory latex-svg-image +library tracing + import: common-lib + visibility: public + hs-source-dirs: tracing + exposed-modules: + Ouroboros.Consensus.Tracing + Ouroboros.Consensus.Tracing.Era.Shelley.Render + Ouroboros.Consensus.Tracing.Render + + other-modules: + Ouroboros.Consensus.Tracing.BlockReplayProgress + Ouroboros.Consensus.Tracing.ChainDB + Ouroboros.Consensus.Tracing.Consensus + Ouroboros.Consensus.Tracing.ConsensusStartupException + Ouroboros.Consensus.Tracing.ConvertTxId + Ouroboros.Consensus.Tracing.Era.Byron + Ouroboros.Consensus.Tracing.Era.HardFork + Ouroboros.Consensus.Tracing.Era.Shelley + Ouroboros.Consensus.Tracing.Formatting + Ouroboros.Consensus.Tracing.HasIssuer + Ouroboros.Consensus.Tracing.KESInfo + + build-depends: + aeson, + base, + base16-bytestring, + bech32, + bytestring, + cardano-crypto-class, + cardano-crypto-wrapper, + cardano-data, + cardano-ledger-allegra, + cardano-ledger-alonzo, + cardano-ledger-api, + cardano-ledger-babbage, + cardano-ledger-binary, + cardano-ledger-byron, + cardano-ledger-conway, + cardano-ledger-core, + cardano-ledger-dijkstra, + cardano-ledger-shelley, + cardano-protocol, + cardano-protocol-tpraos, + cardano-slotting, + containers, + deepseq, + kes-agent, + ouroboros-consensus:{cardano, diffusion, lsm, ouroboros-consensus, protocol}, + ouroboros-network:{api, orphan-instances, ouroboros-network}, + psqueues, + sop-core, + strict-sop-core, + text, + time, + trace-dispatcher ^>=2.13.0, + typed-protocols, + +test-suite tracing-test + import: common-test + type: exitcode-stdio-1.0 + hs-source-dirs: tracing/test + main-is: Main.hs + other-modules: + Test.Consensus.Tracing.Golden + Test.Consensus.Tracing.MetaTrace + + build-depends: + aeson, + base, + bytestring, + cardano-crypto-class, + cardano-data, + cardano-ledger-alonzo, + cardano-ledger-conway, + cardano-ledger-core, + cardano-ledger-dijkstra, + cardano-ledger-mary, + cardano-protocol-tpraos, + containers, + filepath, + ouroboros-consensus:{cardano, diffusion, ouroboros-consensus, protocol, tracing, unstable-consensus-testlib}, + ouroboros-network:{api, ouroboros-network}, + tasty, + tasty-golden, + tasty-hunit, + text, + time, + trace-dispatcher, + library lsm import: common-lib visibility: public diff --git a/scripts/ci/check-changelogs.sh b/scripts/ci/check-changelogs.sh index af2da456f8..7ce29b0894 100755 --- a/scripts/ci/check-changelogs.sh +++ b/scripts/ci/check-changelogs.sh @@ -18,6 +18,7 @@ libraries=("ouroboros-consensus/src/ouroboros-consensus" "ouroboros-consensus-cardano/src/ouroboros-consensus-cardano" "ouroboros-consensus-cardano/src/byron" "ouroboros-consensus-cardano/src/shelley" + "tracing" ) echo "####### Checking for Haskell changes" diff --git a/scripts/ci/run-fourmolu.sh b/scripts/ci/run-fourmolu.sh index 47197fb889..ded9a1364e 100755 --- a/scripts/ci/run-fourmolu.sh +++ b/scripts/ci/run-fourmolu.sh @@ -20,12 +20,7 @@ if ! command -v "$fdcmd" &> /dev/null; then fi fi -case "$(uname -s)" in - MINGW*) path="$(pwd -W | sed 's_/_\\\\_g')\\\\ouroboros-consensus";; - *) path="$(pwd -P)/ouroboros-consensus";; -esac - -$fdcmd --full-path "$path" \ +$fdcmd --exclude docs --exclude scripts \ --extension hs \ --exec-batch fourmolu --config fourmolu.yaml -i diff --git a/tracing/Ouroboros/Consensus/Tracing.hs b/tracing/Ouroboros/Consensus/Tracing.hs new file mode 100644 index 0000000000..3cdf42d2fb --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing.hs @@ -0,0 +1,23 @@ +module Ouroboros.Consensus.Tracing + ( module Ouroboros.Consensus.Tracing.BlockReplayProgress + , module Ouroboros.Consensus.Tracing.ChainDB + , module Ouroboros.Consensus.Tracing.Consensus + , module Ouroboros.Consensus.Tracing.ConsensusStartupException + , module Ouroboros.Consensus.Tracing.ConvertTxId + , module Ouroboros.Consensus.Tracing.HasIssuer + , module Ouroboros.Consensus.Tracing.KESInfo + , module Ouroboros.Consensus.Tracing.Render + ) where + +import Ouroboros.Consensus.Tracing.BlockReplayProgress +import Ouroboros.Consensus.Tracing.ChainDB +import Ouroboros.Consensus.Tracing.Consensus +import Ouroboros.Consensus.Tracing.ConsensusStartupException +import Ouroboros.Consensus.Tracing.ConvertTxId +import Ouroboros.Consensus.Tracing.Era.Byron () +import Ouroboros.Consensus.Tracing.Era.HardFork () +import Ouroboros.Consensus.Tracing.Era.Shelley () +import Ouroboros.Consensus.Tracing.Formatting () +import Ouroboros.Consensus.Tracing.HasIssuer +import Ouroboros.Consensus.Tracing.KESInfo +import Ouroboros.Consensus.Tracing.Render diff --git a/tracing/Ouroboros/Consensus/Tracing/BlockReplayProgress.hs b/tracing/Ouroboros/Consensus/Tracing/BlockReplayProgress.hs new file mode 100644 index 0000000000..40c9a245ce --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/BlockReplayProgress.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Ouroboros.Consensus.Tracing.BlockReplayProgress + ( withReplayedBlock + , ReplayBlockStats (..) + ) where + +import Cardano.Logging +import Control.Concurrent.MVar +import Data.Aeson (Value (String), (.=)) +import Data.Text (Text, pack) +import Numeric (showFFloat) +import Ouroboros.Consensus.Block (SlotNo, realPointSlot) +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import Ouroboros.Network.Block (pointSlot, unSlotNo) +import Ouroboros.Network.Point (withOrigin) + +textShow :: Show a => a -> Text +textShow = pack . show + +newtype ReplayBlockState = ReplayBlockState + { rpsLastSlot :: Maybe SlotNo + -- ^ Last slot for which a `ReplayBlockStats` message has been issued. + } + +data ReplayBlockStats = ReplayBlockStats + { rpsCurSlot :: SlotNo + , rpsGoalSlot :: SlotNo + } + +initialReplayBlockState :: ReplayBlockState +initialReplayBlockState = ReplayBlockState{rpsLastSlot = Nothing} + +progressForMachine :: ReplayBlockStats -> Double +progressForMachine (ReplayBlockStats curSlot goalSlot) = + (fromIntegral (unSlotNo curSlot) * 100.0) / fromIntegral (unSlotNo $ max curSlot goalSlot) + +progressForHuman :: ReplayBlockStats -> Double +progressForHuman = round2 . progressForMachine + where + round2 :: Double -> Double + round2 num = + let + f :: Int + f = round $ num * 100 + in + fromIntegral f / 100 + +-------------------------------------------------------------------------------- +-- ReplayBlockStats Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting ReplayBlockStats where + forMachine _ stats = + mconcat + [ "kind" .= String "ReplayBlockStats" + , "progress" .= String (pack $ show $ progressForMachine stats) + ] + + forHuman stats@ReplayBlockStats{..} = + "Replayed block: slot " + <> textShow (unSlotNo rpsCurSlot) + <> " out of " + <> textShow (unSlotNo rpsGoalSlot) + <> ". Progress: " + <> pack (showFFloat (Just 2) (progressForHuman stats) mempty) + <> "%" + + asMetrics stats = + [DoubleM "blockReplayProgress" (progressForMachine stats)] + +instance MetaTrace ReplayBlockStats where + namespaceFor ReplayBlockStats{} = Namespace [] ["LedgerReplay"] + + severityFor (Namespace _ ["LedgerReplay"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["LedgerReplay"]) = + Just + "Counts block replays and calculates the percent." + documentFor _ = Nothing + + metricsDocFor (Namespace _ ["LedgerReplay"]) = + [("blockReplayProgress", "Progress in percent")] + metricsDocFor _ = [] + + allNamespaces = + [ Namespace [] ["LedgerReplay"] + ] + +withReplayedBlock :: + Trace IO ReplayBlockStats -> + IO (Trace IO (ChainDB.TraceEvent blk)) +withReplayedBlock tr = do + var <- newMVar initialReplayBlockState + contramapMCond tr (process var) + where + process :: + MVar ReplayBlockState -> + (LoggingContext, Either TraceControl (ChainDB.TraceEvent blk)) -> + IO (Maybe (LoggingContext, Either TraceControl ReplayBlockStats)) + process var (ctx, Right msg) = modifyMVar var $ \st -> do + let !(!st', mbStats) = mbProduceBlockStats msg st + pure (st', fmap ((ctx,) . Right) mbStats) + process _ (ctx, Left control) = pure (Just (ctx, Left control)) + + mbProduceBlockStats :: + ChainDB.TraceEvent blk -> ReplayBlockState -> (ReplayBlockState, Maybe ReplayBlockStats) + mbProduceBlockStats + ( ChainDB.TraceLedgerDBEvent + ( LedgerDB.LedgerReplayEvent + ( LedgerDB.TraceReplayProgressEvent + (LedgerDB.ReplayedBlock curSlot [] _ (LedgerDB.ReplayGoal replayToSlot)) + ) + ) + ) + st@(ReplayBlockState mLastSlot) = + let curSlotNo = realPointSlot curSlot + goalSlotNo = withOrigin 0 id $ pointSlot replayToSlot + stats = ReplayBlockStats curSlotNo goalSlotNo + progressFor soFar goal = progressForHuman (ReplayBlockStats soFar goal) + shouldEmit = + maybe + True + (\lastSlot -> progressFor curSlotNo goalSlotNo - progressFor lastSlot goalSlotNo >= 0.01) + mLastSlot + in if shouldEmit + then (ReplayBlockState (Just curSlotNo), Just stats) + else (st, Nothing) + mbProduceBlockStats _ st = (st, Nothing) diff --git a/tracing/Ouroboros/Consensus/Tracing/ChainDB.hs b/tracing/Ouroboros/Consensus/Tracing/ChainDB.hs new file mode 100644 index 0000000000..be743c7b2d --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/ChainDB.hs @@ -0,0 +1,3542 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ouroboros.Consensus.Tracing.ChainDB + ( withAddedToCurrentChainEmptyLimited + , fragmentChainDensity + ) where + +import Cardano.Logging +import Data.Aeson (Object, ToJSON, Value (Object, String), object, toJSON, (.=)) +import qualified Data.ByteString.Base16 as B16 +import Data.Int (Int64) +import qualified Data.List.NonEmpty as NonEmpty +import Data.SOP (All, K (..), hcmap, hcollapse) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Typeable (Typeable, cast) +import Data.Void (absurd) +import Data.Word (Word64) +import Numeric (showFFloat) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork +import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock +import Ouroboros.Consensus.HardFork.Combinator.Info +import Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel +import Ouroboros.Consensus.HeaderValidation + ( HeaderEnvelopeError (..) + , HeaderError (..) + , OtherHeaderEnvelopeError + ) +import Ouroboros.Consensus.Ledger.Abstract (LedgerError) +import Ouroboros.Consensus.Ledger.Extended (ExtValidationError (..)) +import Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent (..)) +import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Protocol.Abstract + ( Comparing (..) + , ReasonForSwitch + , SelectViewReasonForSwitch (..) + , TiebreakerView + , ValidationErr + ) +import qualified Ouroboros.Consensus.Protocol.PBFT as PBFT +import Ouroboros.Consensus.Protocol.Praos.Common +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmDB +import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (chunkNoToInt) +import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB +import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB +import qualified Ouroboros.Consensus.Storage.PerasVoteDB as PerasVoteDB +import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB +import Ouroboros.Consensus.Tracing.Formatting () +import Ouroboros.Consensus.Tracing.HasIssuer +import Ouroboros.Consensus.Tracing.Render +import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util.Condense (condense) +import Ouroboros.Consensus.Util.Enclose +import qualified Ouroboros.Network.AnchoredFragment as AF +import Ouroboros.Network.Block (MaxSlotNo (..)) + +-- {-# ANN module ("HLint: ignore Redundant bracket" :: Text) #-} + +-- A limiter that is not coming from configuration, because it carries a special filter +withAddedToCurrentChainEmptyLimited :: + Trace IO (ChainDB.TraceEvent blk) -> + IO (Trace IO (ChainDB.TraceEvent blk)) +withAddedToCurrentChainEmptyLimited tr = do + ltr <- limitFrequency 1.25 "AddedToCurrentChainLimiter" mempty tr + pure $ routingTrace (selecting ltr) tr + where + selecting + ltr + (ChainDB.TraceAddBlockEvent (ChainDB.AddedToCurrentChain events _ _ _ _)) = + if null events + then pure ltr + else pure tr + selecting _ _ = pure tr + +-- -------------------------------------------------------------------------------- +-- -- ChainDB Tracer +-- -------------------------------------------------------------------------------- + +instance + ( LogFormatting (Header blk) + , LogFormatting (LedgerEvent blk) + , LogFormatting (RealPoint blk) + , LogFormatting (WeightedSelectView (BlockProtocol blk)) + , ConvertRawHash blk + , ConvertRawHash (Header blk) + , LedgerSupportsProtocol blk + , InspectLedger blk + , HasIssuer blk + , LogFormatting (ReasonForSwitch (TiebreakerView (BlockProtocol blk))) + , Show (PerasCert blk) + , Show (PerasError blk) + ) => + LogFormatting (ChainDB.TraceEvent blk) + where + forHuman ChainDB.TraceLastShutdownUnclean = + "ChainDB is not clean. Validating all immutable chunks" + forHuman (ChainDB.TracePerasVoteDbEvent v) = forHuman v + forHuman (ChainDB.TraceAddBlockEvent v) = forHuman v + forHuman (ChainDB.TraceFollowerEvent v) = forHuman v + forHuman (ChainDB.TraceCopyToImmutableDBEvent v) = forHuman v + forHuman (ChainDB.TraceGCEvent v) = forHuman v + forHuman (ChainDB.TraceInitChainSelEvent v) = forHuman v + forHuman (ChainDB.TraceOpenEvent v) = forHuman v + forHuman (ChainDB.TraceIteratorEvent v) = forHuman v + forHuman (ChainDB.TraceLedgerDBEvent v) = forHuman v + forHuman (ChainDB.TraceImmutableDBEvent v) = forHuman v + forHuman (ChainDB.TraceVolatileDBEvent v) = forHuman v + forHuman (ChainDB.TraceChainSelStarvationEvent ev) = case ev of + ChainDB.ChainSelStarvation RisingEdge -> + "Chain Selection was starved." + ChainDB.ChainSelStarvation (FallingEdgeWith pt) -> + "Chain Selection was unstarved by " <> renderRealPoint pt + forHuman (ChainDB.TracePerasCertDbEvent ev) = forHuman ev + forHuman (ChainDB.TraceAddPerasCertEvent ev) = forHuman ev + + forMachine _ ChainDB.TraceLastShutdownUnclean = + mconcat ["kind" .= String "LastShutdownUnclean"] + forMachine dtal (ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation edge)) = + mconcat + [ "kind" .= String "ChainSelStarvation" + , case edge of + RisingEdge -> "risingEdge" .= True + FallingEdgeWith pt -> "fallingEdge" .= forMachine dtal pt + ] + forMachine details (ChainDB.TracePerasVoteDbEvent v) = + forMachine details v + forMachine details (ChainDB.TraceAddBlockEvent v) = + forMachine details v + forMachine details (ChainDB.TraceFollowerEvent v) = + forMachine details v + forMachine details (ChainDB.TraceCopyToImmutableDBEvent v) = + forMachine details v + forMachine details (ChainDB.TraceGCEvent v) = + forMachine details v + forMachine details (ChainDB.TraceInitChainSelEvent v) = + forMachine details v + forMachine details (ChainDB.TraceOpenEvent v) = + forMachine details v + forMachine details (ChainDB.TraceIteratorEvent v) = + forMachine details v + forMachine details (ChainDB.TraceLedgerDBEvent v) = + forMachine details v + forMachine details (ChainDB.TraceImmutableDBEvent v) = + forMachine details v + forMachine details (ChainDB.TraceVolatileDBEvent v) = + forMachine details v + forMachine details (ChainDB.TracePerasCertDbEvent v) = + forMachine details v + forMachine details (ChainDB.TraceAddPerasCertEvent v) = + forMachine details v + + asMetrics ChainDB.TraceLastShutdownUnclean = [] + asMetrics (ChainDB.TraceChainSelStarvationEvent _) = [] + asMetrics (ChainDB.TracePerasVoteDbEvent v) = asMetrics v + asMetrics (ChainDB.TraceAddBlockEvent v) = asMetrics v + asMetrics (ChainDB.TraceFollowerEvent v) = asMetrics v + asMetrics (ChainDB.TraceCopyToImmutableDBEvent v) = asMetrics v + asMetrics (ChainDB.TraceGCEvent v) = asMetrics v + asMetrics (ChainDB.TraceInitChainSelEvent v) = asMetrics v + asMetrics (ChainDB.TraceOpenEvent v) = asMetrics v + asMetrics (ChainDB.TraceIteratorEvent v) = asMetrics v + asMetrics (ChainDB.TraceLedgerDBEvent v) = asMetrics v + asMetrics (ChainDB.TraceImmutableDBEvent v) = asMetrics v + asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v + asMetrics (ChainDB.TracePerasCertDbEvent v) = asMetrics v + asMetrics (ChainDB.TraceAddPerasCertEvent v) = asMetrics v + +instance MetaTrace (ChainDB.TraceEvent blk) where + namespaceFor ChainDB.TraceLastShutdownUnclean = + Namespace [] ["LastShutdownUnclean"] + namespaceFor ChainDB.TraceChainSelStarvationEvent{} = + Namespace [] ["ChainSelStarvationEvent"] + namespaceFor (ChainDB.TracePerasVoteDbEvent ev) = + nsPrependInner "PerasVoteDbEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceAddBlockEvent ev) = + nsPrependInner "AddBlockEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceFollowerEvent ev) = + nsPrependInner "FollowerEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceCopyToImmutableDBEvent ev) = + nsPrependInner "CopyToImmutableDBEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceGCEvent ev) = + nsPrependInner "GCEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceInitChainSelEvent ev) = + nsPrependInner "InitChainSelEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceOpenEvent ev) = + nsPrependInner "OpenEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceIteratorEvent ev) = + nsPrependInner "IteratorEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceLedgerDBEvent ev) = + nsPrependInner "LedgerEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceImmutableDBEvent ev) = + nsPrependInner "ImmDbEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceVolatileDBEvent ev) = + nsPrependInner "VolatileDbEvent" (namespaceFor ev) + namespaceFor (ChainDB.TracePerasCertDbEvent ev) = + nsPrependInner "PerasCertDbEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceAddPerasCertEvent ev) = + nsPrependInner "AddPerasCertEvent" (namespaceFor ev) + + severityFor (Namespace _ ["LastShutdownUnclean"]) _ = Just Info + severityFor (Namespace _ ["ChainSelStarvationEvent"]) _ = Just Debug + severityFor (Namespace out ("AddBlockEvent" : tl)) (Just (ChainDB.TraceAddBlockEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("AddBlockEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceAddBlockEvent blk)) Nothing + severityFor (Namespace out ("FollowerEvent" : tl)) (Just (ChainDB.TraceFollowerEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("FollowerEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceFollowerEvent blk)) Nothing + severityFor (Namespace out ("CopyToImmutableDBEvent" : tl)) (Just (ChainDB.TraceCopyToImmutableDBEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("CopyToImmutableDBEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceCopyToImmutableDBEvent blk)) Nothing + severityFor (Namespace out ("GCEvent" : tl)) (Just (ChainDB.TraceGCEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("GCEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceGCEvent blk)) Nothing + severityFor (Namespace out ("InitChainSelEvent" : tl)) (Just (ChainDB.TraceInitChainSelEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("InitChainSelEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceInitChainSelEvent blk)) Nothing + severityFor (Namespace out ("OpenEvent" : tl)) (Just (ChainDB.TraceOpenEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("OpenEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceOpenEvent blk)) Nothing + severityFor (Namespace out ("IteratorEvent" : tl)) (Just (ChainDB.TraceIteratorEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("IteratorEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) Nothing + severityFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceLedgerDBEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("LedgerEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceEvent blk)) Nothing + severityFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("ImmDbEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) Nothing + severityFor (Namespace out ("VolatileDbEvent" : tl)) (Just (ChainDB.TraceVolatileDBEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("VolatileDbEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) Nothing + severityFor (Namespace out ("PerasVoteDbEvent" : tl)) (Just (ChainDB.TracePerasVoteDbEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("PerasVoteDbEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (PerasVoteDB.TraceEvent blk)) Nothing + severityFor (Namespace out ("PerasCertDbEvent" : tl)) (Just (ChainDB.TracePerasCertDbEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("PerasCertDbEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) Nothing + severityFor (Namespace out ("AddPerasCertEvent" : tl)) (Just (ChainDB.TraceAddPerasCertEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("AddPerasCertEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) Nothing + severityFor _ns _ = Nothing + + privacyFor (Namespace _ ["LastShutdownUnclean"]) _ = Just Public + privacyFor (Namespace _ ["ChainSelStarvationEvent"]) _ = Just Public + privacyFor (Namespace out ("AddBlockEvent" : tl)) (Just (ChainDB.TraceAddBlockEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("AddBlockEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceAddBlockEvent blk)) Nothing + privacyFor (Namespace out ("FollowerEvent" : tl)) (Just (ChainDB.TraceFollowerEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("FollowerEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceFollowerEvent blk)) Nothing + privacyFor (Namespace out ("CopyToImmutableDBEvent" : tl)) (Just (ChainDB.TraceCopyToImmutableDBEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("CopyToImmutableDBEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceCopyToImmutableDBEvent blk)) Nothing + privacyFor (Namespace out ("GCEvent" : tl)) (Just (ChainDB.TraceGCEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("GCEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceGCEvent blk)) Nothing + privacyFor (Namespace out ("InitChainSelEvent" : tl)) (Just (ChainDB.TraceInitChainSelEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("InitChainSelEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceInitChainSelEvent blk)) Nothing + privacyFor (Namespace out ("OpenEvent" : tl)) (Just (ChainDB.TraceOpenEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("OpenEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceOpenEvent blk)) Nothing + privacyFor (Namespace out ("IteratorEvent" : tl)) (Just (ChainDB.TraceIteratorEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("IteratorEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) Nothing + privacyFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceLedgerDBEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("LedgerEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (LedgerDB.TraceEvent blk)) Nothing + privacyFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("ImmDbEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) Nothing + privacyFor (Namespace out ("VolatileDbEvent" : tl)) (Just (ChainDB.TraceVolatileDBEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("VolatileDbEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) Nothing + privacyFor (Namespace out ("PerasVoteDbEvent" : tl)) (Just (ChainDB.TracePerasVoteDbEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("PerasVoteDbEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (PerasVoteDB.TraceEvent blk)) Nothing + privacyFor (Namespace out ("PerasCertDbEvent" : tl)) (Just (ChainDB.TracePerasCertDbEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("PerasCertDbEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) Nothing + privacyFor (Namespace out ("AddPerasCertEvent" : tl)) (Just (ChainDB.TraceAddPerasCertEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("AddPerasCertEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) Nothing + privacyFor _ _ = Nothing + + detailsFor (Namespace _ ["LastShutdownUnclean"]) _ = Just DNormal + detailsFor (Namespace _ ["ChainSelStarvationEvent"]) _ = Just DNormal + detailsFor (Namespace out ("AddBlockEvent" : tl)) (Just (ChainDB.TraceAddBlockEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("AddBlockEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceAddBlockEvent blk)) Nothing + detailsFor (Namespace out ("FollowerEvent" : tl)) (Just (ChainDB.TraceFollowerEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("FollowerEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceFollowerEvent blk)) Nothing + detailsFor (Namespace out ("CopyToImmutableDBEvent" : tl)) (Just (ChainDB.TraceCopyToImmutableDBEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("CopyToImmutableDBEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceCopyToImmutableDBEvent blk)) Nothing + detailsFor (Namespace out ("GCEvent" : tl)) (Just (ChainDB.TraceGCEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("GCEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceGCEvent blk)) Nothing + detailsFor (Namespace out ("InitChainSelEvent" : tl)) (Just (ChainDB.TraceInitChainSelEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("InitChainSelEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceInitChainSelEvent blk)) Nothing + detailsFor (Namespace out ("OpenEvent" : tl)) (Just (ChainDB.TraceOpenEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("OpenEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceOpenEvent blk)) Nothing + detailsFor (Namespace out ("IteratorEvent" : tl)) (Just (ChainDB.TraceIteratorEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("IteratorEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) Nothing + detailsFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceLedgerDBEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("LedgerEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (LedgerDB.TraceEvent blk)) Nothing + detailsFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("ImmDbEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: (Namespace (ImmDB.TraceEvent blk))) Nothing + detailsFor (Namespace out ("VolatileDbEvent" : tl)) (Just (ChainDB.TraceVolatileDBEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("VolatileDbEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: (Namespace (VolDB.TraceEvent blk))) Nothing + detailsFor (Namespace out ("PerasVoteDbEvent" : tl)) (Just (ChainDB.TracePerasVoteDbEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("PerasVoteDbEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (PerasVoteDB.TraceEvent blk)) Nothing + detailsFor (Namespace out ("PerasCertDbEvent" : tl)) (Just (ChainDB.TracePerasCertDbEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("PerasCertDbEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) Nothing + detailsFor (Namespace out ("AddPerasCertEvent" : tl)) (Just (ChainDB.TraceAddPerasCertEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("AddPerasCertEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) Nothing + detailsFor _ _ = Nothing + + metricsDocFor (Namespace out ("AddBlockEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceAddBlockEvent blk)) + metricsDocFor (Namespace out ("FollowerEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceFollowerEvent blk)) + metricsDocFor (Namespace out ("CopyToImmutableDBEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceCopyToImmutableDBEvent blk)) + metricsDocFor (Namespace out ("GCEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceGCEvent blk)) + metricsDocFor (Namespace out ("InitChainSelEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceInitChainSelEvent blk)) + metricsDocFor (Namespace out ("OpenEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceOpenEvent blk)) + metricsDocFor (Namespace out ("IteratorEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) + metricsDocFor (Namespace out ("LedgerEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (LedgerDB.TraceEvent blk)) + metricsDocFor (Namespace out ("ImmDbEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) + metricsDocFor (Namespace out ("VolatileDbEvent" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) + metricsDocFor _ = [] + + documentFor (Namespace _ ["LastShutdownUnclean"]) = + Just $ + mconcat + [ "Last shutdown of the node didn't leave the ChainDB directory in a clean" + , " state. Therefore, revalidating all the immutable chunks is necessary to" + , " ensure the correctness of the chain." + ] + documentFor (Namespace _ ["ChainSelStarvationEvent"]) = + Just $ + mconcat + [ "ChainSel is waiting for a next block to process, but there is no block in the queue." + , " Despite the name, it is a pretty normal (and frequent) event." + ] + documentFor (Namespace out ("AddBlockEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceAddBlockEvent blk)) + documentFor (Namespace out ("FollowerEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceFollowerEvent blk)) + documentFor (Namespace out ("CopyToImmutableDBEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceCopyToImmutableDBEvent blk)) + documentFor (Namespace out ("GCEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceGCEvent blk)) + documentFor (Namespace out ("InitChainSelEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceInitChainSelEvent blk)) + documentFor (Namespace out ("OpenEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceOpenEvent blk)) + documentFor (Namespace out ("IteratorEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) + documentFor (Namespace out ("LedgerEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (LedgerDB.TraceEvent blk)) + documentFor (Namespace out ("ImmDbEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) + documentFor (Namespace out ("VolatileDbEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) + documentFor (Namespace out ("PerasVoteDbEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (PerasVoteDB.TraceEvent blk)) + documentFor (Namespace out ("PerasCertDbEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) + documentFor (Namespace out ("AddPerasCertEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) + documentFor _ = Nothing + + allNamespaces = + Namespace [] ["LastShutdownUnclean"] + : Namespace [] ["ChainSelStarvationEvent"] + : ( map + (nsPrependInner "AddBlockEvent") + (allNamespaces :: [Namespace (ChainDB.TraceAddBlockEvent blk)]) + ++ map + (nsPrependInner "FollowerEvent") + (allNamespaces :: [Namespace (ChainDB.TraceFollowerEvent blk)]) + ++ map + (nsPrependInner "CopyToImmutableDBEvent") + (allNamespaces :: [Namespace (ChainDB.TraceCopyToImmutableDBEvent blk)]) + ++ map + (nsPrependInner "GCEvent") + (allNamespaces :: [Namespace (ChainDB.TraceGCEvent blk)]) + ++ map + (nsPrependInner "InitChainSelEvent") + (allNamespaces :: [Namespace (ChainDB.TraceInitChainSelEvent blk)]) + ++ map + (nsPrependInner "OpenEvent") + (allNamespaces :: [Namespace (ChainDB.TraceOpenEvent blk)]) + ++ map + (nsPrependInner "IteratorEvent") + (allNamespaces :: [Namespace (ChainDB.TraceIteratorEvent blk)]) + ++ map + (nsPrependInner "LedgerEvent") + (allNamespaces :: [Namespace (LedgerDB.TraceEvent blk)]) + ++ map + (nsPrependInner "ImmDbEvent") + (allNamespaces :: [Namespace (ImmDB.TraceEvent blk)]) + ++ map + (nsPrependInner "VolatileDbEvent") + (allNamespaces :: [Namespace (VolDB.TraceEvent blk)]) + ++ map + (nsPrependInner "PerasVoteDbEvent") + (allNamespaces :: [Namespace (PerasVoteDB.TraceEvent blk)]) + ++ map + (nsPrependInner "PerasCertDbEvent") + (allNamespaces :: [Namespace (PerasCertDB.TraceEvent blk)]) + ++ map + (nsPrependInner "AddPerasCertEvent") + (allNamespaces :: [Namespace (ChainDB.TraceAddPerasCertEvent blk)]) + ) + +-------------------------------------------------------------------------------- +-- AddBlockEvent +-------------------------------------------------------------------------------- + +instance LogFormatting (PraosReasonForSwitch c) where + forHuman (HigherOCert (Comparing ref cand)) = + "candidate has higher OCert (" <> showT cand <> ") than our selection (" <> showT ref <> ")" + forHuman (VRFTiebreak (Comparing ref cand)) = + "candidate has lower VRF (" <> showT cand <> ") than our selection (" <> showT ref <> ")" + forMachine _dtal (HigherOCert (Comparing ref cand)) = + mconcat + [ "reason" .= String "HigherOCert" + , "our" .= String (showT ref) + , "candidate" .= String (showT cand) + ] + forMachine _dtal (VRFTiebreak (Comparing ref cand)) = + mconcat + [ "reason" .= String "VRFTiebreak" + , "our" .= String (showT ref) + , "candidate" .= String (showT cand) + ] + +class (LogFormatting (ReasonForSwitch (TiebreakerView (BlockProtocol a))), SingleEraBlock a) => LFTBV a +instance (LogFormatting (ReasonForSwitch (TiebreakerView (BlockProtocol a))), SingleEraBlock a) => LFTBV a + +instance (All LFTBV xs, CanHardFork xs) => LogFormatting (OneEraReasonForSwitch xs) where + forHuman (OneEraReasonForSwitch ns) = + hcollapse $ hcmap (Proxy @LFTBV) msg ns + where + msg :: forall era. LFTBV era => WrapReasonForSwitch era -> K Text era + msg (WrapReasonForSwitch rs) = + K $ + "in era " <> singleEraName (singleEraInfo (Proxy @era)) <> ": " <> forHuman rs + forMachine dtal (OneEraReasonForSwitch ns) = + hcollapse $ hcmap (Proxy @LFTBV) msg ns + where + msg :: forall era. LFTBV era => WrapReasonForSwitch era -> K Object era + msg (WrapReasonForSwitch rs) = + K $ + forMachine dtal rs <> mconcat ["era" .= String (singleEraName (singleEraInfo (Proxy @era)))] + +instance + LogFormatting (ReasonForSwitch (TiebreakerView proto)) => + LogFormatting (WeightedSelectViewReasonForSwitch proto) + where + forHuman (Heavier (Comparing ref cand)) = + "candidate is heavier (" <> showT cand <> ") than our selection (" <> showT ref <> ")" + forHuman (WeightedSelectViewTiebreak reason) = forHuman reason + forMachine _dtal (Heavier (Comparing ref cand)) = + mconcat + [ "reason" .= String "HigherOCert" + , "our" .= String (showT ref) + , "candidate" .= String (showT cand) + ] + forMachine dtal (WeightedSelectViewTiebreak reason) = + forMachine dtal reason + +instance + LogFormatting (ReasonForSwitch (TiebreakerView proto)) => + LogFormatting + ( Either + ( WithEmptyFragmentReasonForSwitch + (WeightedSelectView proto) + ) + (SelectViewReasonForSwitch proto) + ) + where + forHuman (Left CandidateIsNonEmpty) = "candidate is an extension of our selection" + forHuman (Left (BothAreNonEmpty a)) = forHuman a + forHuman (Right (Longer (Comparing ref cand))) = + "candidate is longer (" <> showT cand <> ") than our selection (" <> showT ref <> ")" + forHuman (Right (SelectViewTiebreak a)) = forHuman a + forMachine _dtal (Left CandidateIsNonEmpty) = + mconcat ["reason" .= String "extension"] + forMachine dtal (Left (BothAreNonEmpty a)) = forMachine dtal a + forMachine _dtal (Right (Longer (Comparing ref cand))) = + mconcat + ["reason" .= String "Longer", "our" .= String (showT ref), "candidate" .= String (showT cand)] + forMachine dtal (Right (SelectViewTiebreak a)) = forMachine dtal a + +instance + ( LogFormatting (Header blk) + , LogFormatting (LedgerEvent blk) + , LogFormatting (RealPoint blk) + , LogFormatting (WeightedSelectView (BlockProtocol blk)) + , LogFormatting + ( Either + (WithEmptyFragmentReasonForSwitch (WeightedSelectView (BlockProtocol blk))) + (SelectViewReasonForSwitch (BlockProtocol blk)) + ) + , ConvertRawHash blk + , ConvertRawHash (Header blk) + , LedgerSupportsProtocol blk + , InspectLedger blk + , HasIssuer blk + , Show (PerasError blk) + ) => + LogFormatting (ChainDB.TraceAddBlockEvent blk) + where + forHuman (ChainDB.IgnoreBlockOlderThanImmTip pt) = + "Ignoring block older than ImmTip: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.IgnoreBlockAlreadyInVolatileDB pt) = + "Ignoring block already in DB: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.IgnoreInvalidBlock pt _reason) = + "Ignoring previously seen invalid block: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.AddedBlockToQueue pt edgeSz) = + case edgeSz of + RisingEdge -> + "About to add block to queue: " <> renderRealPointAsPhrase pt + FallingEdgeWith sz -> + "Block added to queue: " <> renderRealPointAsPhrase pt <> ", queue size " <> condenseT sz + forHuman ChainDB.PoppingFromQueue = + "Popping block from queue" + forHuman (ChainDB.PoppedBlockFromQueue pt) = + "Popped block from queue: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.StoreButDontChange pt) = + "Ignoring block: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.TryAddToCurrentChain pt) = + "Block fits onto the current chain: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.TrySwitchToAFork pt _) = + "Block fits onto some fork: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.ChangingSelection pt) = + "Changing selection to: " <> renderPointAsPhrase pt + forHuman (ChainDB.AddedToCurrentChain es _ _ c _) = + "Chain extended, new tip: " + <> renderPointAsPhrase (AF.headPoint c) + <> Text.concat ["\nEvent: " <> showT e | e <- es] + forHuman (ChainDB.SwitchedToAFork es _ _ c reasonForSwitch) = + "Switched to a fork, new tip: " + <> renderPointAsPhrase (AF.headPoint c) + <> Text.concat ["\nEvent: " <> showT e | e <- es] + <> "\nReason: " + <> forHuman reasonForSwitch + forHuman (ChainDB.AddBlockValidation ev') = forHuman ev' + forHuman (ChainDB.AddedBlockToVolatileDB pt _ _ enclosing) = + case enclosing of + RisingEdge -> "Chain about to add block " <> renderRealPointAsPhrase pt + FallingEdge -> "Chain added block " <> renderRealPointAsPhrase pt + forHuman (ChainDB.PipeliningEvent ev') = forHuman ev' + forHuman (ChainDB.AddedReprocessLoEBlocksToQueue edgeSz) = + case edgeSz of + RisingEdge -> + "About to add request to queue to reprocess blocks postponed by LoE." + FallingEdgeWith sz -> + "Added request to queue to reprocess blocks postponed by LoE" <> ", queue size " <> condenseT sz + forHuman ChainDB.PoppedReprocessLoEBlocksFromQueue = + "Poppped request from queue to reprocess blocks postponed by LoE." + forHuman ChainDB.ChainSelectionLoEDebug{} = + "ChainDB LoE debug event" + forMachine dtal (ChainDB.IgnoreBlockOlderThanImmTip pt) = + mconcat + [ "kind" .= String "IgnoreBlockOlderThanImmTip" + , "block" .= forMachine dtal pt + ] + forMachine dtal (ChainDB.IgnoreBlockAlreadyInVolatileDB pt) = + mconcat + [ "kind" .= String "IgnoreBlockAlreadyInVolatileDB" + , "block" .= forMachine dtal pt + ] + forMachine dtal (ChainDB.IgnoreInvalidBlock pt reason) = + mconcat + [ "kind" .= String "IgnoreInvalidBlock" + , "block" .= forMachine dtal pt + , "reason" .= showT reason + ] + forMachine dtal (ChainDB.AddedBlockToQueue pt edgeSz) = + mconcat + [ "kind" .= String "AddedBlockToQueue" + , "block" .= forMachine dtal pt + , case edgeSz of + RisingEdge -> "risingEdge" .= True + FallingEdgeWith sz -> "queueSize" .= toJSON sz + ] + forMachine _dtal ChainDB.PoppingFromQueue = + mconcat + [ "kind" .= String "PoppingFromQueue" + ] + forMachine dtal (ChainDB.PoppedBlockFromQueue pt) = + mconcat + [ "kind" .= String "TraceAddBlockEvent.PoppedBlockFromQueue" + , "block" .= forMachine dtal pt + ] + forMachine dtal (ChainDB.StoreButDontChange pt) = + mconcat + [ "kind" .= String "StoreButDontChange" + , "block" .= forMachine dtal pt + ] + forMachine dtal (ChainDB.TryAddToCurrentChain pt) = + mconcat + [ "kind" .= String "TryAddToCurrentChain" + , "block" .= forMachine dtal pt + ] + forMachine dtal (ChainDB.TrySwitchToAFork pt _) = + mconcat + [ "kind" .= String "TraceAddBlockEvent.TrySwitchToAFork" + , "block" .= forMachine dtal pt + ] + forMachine dtal (ChainDB.ChangingSelection pt) = + mconcat + [ "kind" .= String "TraceAddBlockEvent.ChangingSelection" + , "block" .= forMachine dtal pt + ] + forMachine DDetailed (ChainDB.AddedToCurrentChain events selChangedInfo base extended _) = + let ChainInformation{..} = chainInformation selChangedInfo base extended 0 + tipBlockIssuerVkHashText :: Text + tipBlockIssuerVkHashText = + case tipBlockIssuerVerificationKeyHash of + NoBlockIssuer -> "NoBlockIssuer" + BlockIssuerVerificationKeyHash bs -> + Text.decodeLatin1 (B16.encode bs) + in mconcat $ + [ "kind" .= String "AddedToCurrentChain" + , "newtip" .= renderPointForDetails DDetailed (AF.headPoint extended) + , "newSuffixSelectView" .= forMachine DDetailed (ChainDB.newSuffixSelectView selChangedInfo) + ] + ++ [ "oldSuffixSelectView" .= forMachine DDetailed oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] + ] + ++ [ "headers" .= toJSON (forMachine DDetailed `map` addedHdrsNewChain base extended) + ] + ++ [ "events" .= toJSON (map (forMachine DDetailed) events) + | not (null events) + ] + ++ [ "tipBlockHash" .= tipBlockHash + , "tipBlockParentHash" .= tipBlockParentHash + , "tipBlockIssuerVKeyHash" .= tipBlockIssuerVkHashText + ] + forMachine dtal (ChainDB.AddedToCurrentChain events selChangedInfo _base extended _) = + mconcat $ + [ "kind" .= String "AddedToCurrentChain" + , "newtip" .= renderPointForDetails dtal (AF.headPoint extended) + , "newSuffixSelectView" .= forMachine dtal (ChainDB.newSuffixSelectView selChangedInfo) + ] + ++ [ "oldSuffixSelectView" .= forMachine dtal oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] + ] + ++ [ "events" .= toJSON (map (forMachine dtal) events) + | not (null events) + ] + forMachine DDetailed (ChainDB.SwitchedToAFork events selChangedInfo old new reasonForSwitch) = + let ChainInformation{..} = chainInformation selChangedInfo old new 0 + tipBlockIssuerVkHashText :: Text + tipBlockIssuerVkHashText = + case tipBlockIssuerVerificationKeyHash of + NoBlockIssuer -> "NoBlockIssuer" + BlockIssuerVerificationKeyHash bs -> + Text.decodeLatin1 (B16.encode bs) + in mconcat $ + [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork" + , "newtip" .= renderPointForDetails DDetailed (AF.headPoint new) + , "newSuffixSelectView" .= forMachine DDetailed (ChainDB.newSuffixSelectView selChangedInfo) + ] + ++ [ "oldSuffixSelectView" .= forMachine DDetailed oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] + ] + ++ [ "headers" .= toJSON (forMachine DDetailed `map` addedHdrsNewChain old new) + ] + ++ [ "events" .= toJSON (map (forMachine DDetailed) events) + | not (null events) + ] + ++ [ "tipBlockHash" .= tipBlockHash + , "tipBlockParentHash" .= tipBlockParentHash + , "tipBlockIssuerVKeyHash" .= tipBlockIssuerVkHashText + ] + ++ ["reason" .= forMachine DDetailed reasonForSwitch] + forMachine dtal (ChainDB.SwitchedToAFork events selChangedInfo _old new reasonForSwitch) = + mconcat $ + [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork" + , "newtip" .= renderPointForDetails dtal (AF.headPoint new) + , "newSuffixSelectView" .= forMachine dtal (ChainDB.newSuffixSelectView selChangedInfo) + ] + ++ [ "oldSuffixSelectView" .= forMachine dtal oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] + ] + ++ [ "events" .= toJSON (map (forMachine dtal) events) + | not (null events) + ] + ++ ["reason" .= forMachine dtal reasonForSwitch] + forMachine dtal (ChainDB.AddBlockValidation ev') = + forMachine dtal ev' + forMachine dtal (ChainDB.AddedBlockToVolatileDB pt (BlockNo bn) _ enclosing) = + mconcat $ + [ "kind" .= String "AddedBlockToVolatileDB" + , "block" .= forMachine dtal pt + , "blockNo" .= showT bn + ] + <> ["risingEdge" .= True | RisingEdge <- [enclosing]] + forMachine dtal (ChainDB.PipeliningEvent ev') = + forMachine dtal ev' + forMachine _dtal (ChainDB.AddedReprocessLoEBlocksToQueue edgeSz) = + mconcat + [ "kind" .= String "AddedReprocessLoEBlocksToQueue" + , case edgeSz of + RisingEdge -> "risingEdge" .= True + FallingEdgeWith sz -> "queueSize" .= toJSON sz + ] + forMachine _dtal ChainDB.PoppedReprocessLoEBlocksFromQueue = + mconcat ["kind" .= String "PoppedReprocessLoEBlocksFromQueue"] + forMachine dtal (ChainDB.ChainSelectionLoEDebug curChain loeFrag) = + case loeFrag of + ChainDB.LoEEnabled loeF -> + mconcat + [ "kind" .= String "ChainSelectionLoEDebug" + , "curChain" .= headAndAnchor curChain + , "loeFrag" .= headAndAnchor loeF + ] + ChainDB.LoEDisabled -> + mconcat + [ "kind" .= String "ChainSelectionLoEDebug" + , "curChain" .= headAndAnchor curChain + , "loeFrag" .= String "LoE is disabled" + ] + where + headAndAnchor frag = + object + [ "anchor" .= forMachine dtal (AF.anchorPoint frag) + , "head" .= forMachine dtal (AF.headPoint frag) + ] + + asMetrics (ChainDB.SwitchedToAFork _warnings selChangedInfo oldChain newChain _) = + let forkIt = + not $ + AF.withinFragmentBounds + (AF.headPoint oldChain) + newChain + ChainInformation{..} = chainInformation selChangedInfo oldChain newChain 0 + tipBlockIssuerVkHashText = + case tipBlockIssuerVerificationKeyHash of + NoBlockIssuer -> "NoBlockIssuer" + BlockIssuerVerificationKeyHash bs -> + Text.decodeLatin1 (B16.encode bs) + in [ DoubleM "density" (fromRational density) + , IntM "slotNum" (fromIntegral slots) + , IntM "blockNum" (fromIntegral blocks) + , IntM "slotInEpoch" (fromIntegral slotInEpoch) + , IntM "epoch" (fromIntegral (unEpochNo epoch)) + , CounterM "forks" (Just (if forkIt then 1 else 0)) + , PrometheusM + "tipBlock" + [ ("hash", tipBlockHash) + , ("parent_hash", tipBlockParentHash) + , ("issuer_VKey_hash", tipBlockIssuerVkHashText) + ] + ] + asMetrics (ChainDB.AddedToCurrentChain _warnings selChangedInfo oldChain newChain _) = + let ChainInformation{..} = + chainInformation selChangedInfo oldChain newChain 0 + tipBlockIssuerVkHashText = + case tipBlockIssuerVerificationKeyHash of + NoBlockIssuer -> "NoBlockIssuer" + BlockIssuerVerificationKeyHash bs -> + Text.decodeLatin1 (B16.encode bs) + in [ DoubleM "density" (fromRational density) + , IntM "slotNum" (fromIntegral slots) + , IntM "blockNum" (fromIntegral blocks) + , IntM "slotInEpoch" (fromIntegral slotInEpoch) + , IntM "epoch" (fromIntegral (unEpochNo epoch)) + , PrometheusM + "tipBlock" + [ ("hash", tipBlockHash) + , ("parent_hash", tipBlockParentHash) + , ("issuer_verification_key_hash", tipBlockIssuerVkHashText) + ] + ] + asMetrics _ = [] + +instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where + namespaceFor ChainDB.IgnoreBlockOlderThanImmTip{} = + Namespace [] ["IgnoreBlockOlderThanImmTip"] + namespaceFor ChainDB.IgnoreBlockAlreadyInVolatileDB{} = + Namespace [] ["IgnoreBlockAlreadyInVolatileDB"] + namespaceFor ChainDB.IgnoreInvalidBlock{} = + Namespace [] ["IgnoreInvalidBlock"] + namespaceFor ChainDB.AddedBlockToQueue{} = + Namespace [] ["AddedBlockToQueue"] + namespaceFor ChainDB.PoppingFromQueue{} = + Namespace [] ["PoppingFromQueue"] + namespaceFor ChainDB.PoppedBlockFromQueue{} = + Namespace [] ["PoppedBlockFromQueue"] + namespaceFor ChainDB.AddedBlockToVolatileDB{} = + Namespace [] ["AddedBlockToVolatileDB"] + namespaceFor ChainDB.TryAddToCurrentChain{} = + Namespace [] ["TryAddToCurrentChain"] + namespaceFor ChainDB.TrySwitchToAFork{} = + Namespace [] ["TrySwitchToAFork"] + namespaceFor ChainDB.StoreButDontChange{} = + Namespace [] ["StoreButDontChange"] + namespaceFor ChainDB.AddedToCurrentChain{} = + Namespace [] ["AddedToCurrentChain"] + namespaceFor ChainDB.SwitchedToAFork{} = + Namespace [] ["SwitchedToAFork"] + namespaceFor ChainDB.ChangingSelection{} = + Namespace [] ["ChangingSelection"] + namespaceFor (ChainDB.AddBlockValidation ev') = + nsPrependInner "AddBlockValidation" (namespaceFor ev') + namespaceFor (ChainDB.PipeliningEvent ev') = + nsPrependInner "PipeliningEvent" (namespaceFor ev') + namespaceFor ChainDB.AddedReprocessLoEBlocksToQueue{} = + Namespace [] ["AddedReprocessLoEBlocksToQueue"] + namespaceFor ChainDB.PoppedReprocessLoEBlocksFromQueue = + Namespace [] ["PoppedReprocessLoEBlocksFromQueue"] + namespaceFor ChainDB.ChainSelectionLoEDebug{} = + Namespace [] ["ChainSelectionLoEDebug"] + + severityFor (Namespace _ ["IgnoreBlockOlderThanImmTip"]) _ = Just Info + severityFor (Namespace _ ["IgnoreBlockAlreadyInVolatileDB"]) _ = Just Info + severityFor (Namespace _ ["IgnoreInvalidBlock"]) _ = Just Info + severityFor (Namespace _ ["AddedBlockToQueue"]) _ = Just Debug + severityFor (Namespace _ ["AddedBlockToVolatileDB"]) _ = Just Debug + severityFor (Namespace _ ["PoppingFromQueue"]) _ = Just Debug + severityFor (Namespace _ ["PoppedBlockFromQueue"]) _ = Just Debug + severityFor (Namespace _ ["TryAddToCurrentChain"]) _ = Just Debug + severityFor (Namespace _ ["TrySwitchToAFork"]) _ = Just Info + severityFor (Namespace _ ["StoreButDontChange"]) _ = Just Debug + severityFor (Namespace _ ["ChangingSelection"]) _ = Just Debug + severityFor + (Namespace _ ["AddedToCurrentChain"]) + (Just (ChainDB.AddedToCurrentChain events _ _ _ _)) = + Just $ foldr (max . sevLedgerEvent) Notice events + severityFor (Namespace _ ["AddedToCurrentChain"]) Nothing = Just Notice + severityFor + (Namespace _ ["SwitchedToAFork"]) + (Just (ChainDB.SwitchedToAFork events _ _ _ _)) = + Just $ foldr (max . sevLedgerEvent) Notice events + severityFor (Namespace _ ["SwitchedToAFork"]) _ = + Just Notice + severityFor + (Namespace out ("AddBlockValidation" : tl)) + (Just (ChainDB.AddBlockValidation ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace _ ("AddBlockValidation" : _tl)) Nothing = Just Notice + severityFor (Namespace out ("PipeliningEvent" : tl)) (Just (ChainDB.PipeliningEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("PipeliningEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TracePipeliningEvent blk)) Nothing + severityFor (Namespace _ ["AddedReprocessLoEBlocksToQueue"]) _ = Just Debug + severityFor (Namespace _ ["PoppedReprocessLoEBlocksFromQueue"]) _ = Just Debug + severityFor (Namespace _ ["ChainSelectionLoEDebug"]) _ = Just Debug + severityFor _ _ = Nothing + + privacyFor (Namespace out ("AddBlockValidation" : tl)) (Just (ChainDB.AddBlockValidation ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("AddBlockValidation" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceValidationEvent blk)) Nothing + privacyFor (Namespace out ("PipeliningEvent" : tl)) (Just (ChainDB.PipeliningEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("PipeliningEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TracePipeliningEvent blk)) Nothing + privacyFor _ _ = Just Public + + detailsFor (Namespace out ("AddBlockValidation" : tl)) (Just (ChainDB.AddBlockValidation ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("AddBlockValidation" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceValidationEvent blk)) Nothing + detailsFor (Namespace out ("PipeliningEvent" : tl)) (Just (ChainDB.PipeliningEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("PipeliningEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TracePipeliningEvent blk)) Nothing + detailsFor _ _ = Just DNormal + + metricsDocFor (Namespace _ ["SwitchedToAFork"]) = + [ + ( "density" + , mconcat + [ "The actual number of blocks created over the maximum expected number" + , " of blocks that could be created over the span of the last @k@ blocks." + ] + ) + , + ( "slotNum" + , "Number of slots in this chain fragment." + ) + , + ( "blockNum" + , "Number of blocks in this chain fragment." + ) + , + ( "slotInEpoch" + , mconcat + [ "Relative slot number of the tip of the current chain within the" + , " epoch.." + ] + ) + , + ( "epoch" + , "In which epoch is the tip of the current chain." + ) + , + ( "forks" + , "counter for forks" + ) + , + ( "tipBlock" + , "Values for hash, parent hash and issuer verification key hash" + ) + ] + metricsDocFor (Namespace _ ["AddedToCurrentChain"]) = + [ + ( "density" + , mconcat + [ "The actual number of blocks created over the maximum expected number" + , " of blocks that could be created over the span of the last @k@ blocks." + ] + ) + , + ( "slotNum" + , "Number of slots in this chain fragment." + ) + , + ( "blockNum" + , "Number of blocks in this chain fragment." + ) + , + ( "slotInEpoch" + , mconcat + [ "Relative slot number of the tip of the current chain within the" + , " epoch.." + ] + ) + , + ( "epoch" + , "In which epoch is the tip of the current chain." + ) + , + ( "tipBlock" + , "Values for hash, parent hash and issuer verification key hash" + ) + ] + metricsDocFor _ = [] + + documentFor (Namespace _ ["IgnoreBlockOlderThanImmTip"]) = + Just + "A block with a 'BlockNo' not newer than the immutable tip was ignored." + documentFor (Namespace _ ["IgnoreBlockAlreadyInVolatileDB"]) = + Just + "A block that is already in the Volatile DB was ignored." + documentFor (Namespace _ ["IgnoreInvalidBlock"]) = + Just + "A block that is invalid was ignored." + documentFor (Namespace _ ["AddedBlockToQueue"]) = + Just $ + mconcat + [ "The block was added to the queue and will be added to the ChainDB by" + , " the background thread. The size of the queue is included.." + ] + documentFor (Namespace _ ["AddedBlockToVolatileDB"]) = + Just + "A block was added to the Volatile DB" + documentFor (Namespace _ ["PoppingFromQueue"]) = Just "" + documentFor (Namespace _ ["PoppedBlockFromQueue"]) = Just "" + documentFor (Namespace _ ["TryAddToCurrentChain"]) = + Just $ + mconcat + [ "The block fits onto the current chain, we'll try to use it to extend" + , " our chain." + ] + documentFor (Namespace _ ["TrySwitchToAFork"]) = + Just $ + mconcat + [ "The block fits onto some fork, we'll try to switch to that fork (if" + , " it is preferable to our chain)" + ] + documentFor (Namespace _ ["StoreButDontChange"]) = + Just $ + mconcat + [ "The block fits onto some fork, we'll try to switch to that fork (if" + , " it is preferable to our chain)." + ] + documentFor (Namespace _ ["ChangingSelection"]) = + Just $ + mconcat + [ "The new block fits onto the current chain (first" + , " fragment) and we have successfully used it to extend our (new) current" + , " chain (second fragment)." + ] + documentFor (Namespace _ ["AddedToCurrentChain"]) = + Just $ + mconcat + [ "The new block fits onto the current chain (first" + , " fragment) and we have successfully used it to extend our (new) current" + , " chain (second fragment)." + ] + documentFor (Namespace _out ["SwitchedToAFork"]) = + Just $ + mconcat + [ "The new block fits onto some fork and we have switched to that fork" + , " (second fragment), as it is preferable to our (previous) current chain" + , " (first fragment)." + ] + documentFor (Namespace out ("AddBlockValidation" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceValidationEvent blk)) + documentFor (Namespace out ("PipeliningEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TracePipeliningEvent blk)) + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["IgnoreBlockOlderThanImmTip"] + , Namespace [] ["IgnoreBlockAlreadyInVolatileDB"] + , Namespace [] ["IgnoreInvalidBlock"] + , Namespace [] ["AddedBlockToQueue"] + , Namespace [] ["AddedBlockToVolatileDB"] + , Namespace [] ["PoppingFromQueue"] + , Namespace [] ["PoppedBlockFromQueue"] + , Namespace [] ["TryAddToCurrentChain"] + , Namespace [] ["TrySwitchToAFork"] + , Namespace [] ["StoreButDontChange"] + , Namespace [] ["ChangingSelection"] + , Namespace [] ["AddedToCurrentChain"] + , Namespace [] ["SwitchedToAFork"] + , Namespace [] ["AddedReprocessLoEBlocksToQueue"] + , Namespace [] ["PoppedReprocessLoEBlocksFromQueue"] + , Namespace [] ["ChainSelectionLoEDebug"] + ] + ++ map + (nsPrependInner "PipeliningEvent") + (allNamespaces :: [Namespace (ChainDB.TracePipeliningEvent blk)]) + ++ map + (nsPrependInner "AddBlockValidation") + (allNamespaces :: [Namespace (ChainDB.TraceValidationEvent blk)]) + +-------------------------------------------------------------------------------- +-- ChainDB TracePipeliningEvent +-------------------------------------------------------------------------------- + +instance + ( ConvertRawHash (Header blk) + , HasHeader (Header blk) + ) => + LogFormatting (ChainDB.TracePipeliningEvent blk) + where + forHuman (ChainDB.SetTentativeHeader hdr enclosing) = + case enclosing of + RisingEdge -> "About to set tentative header to " <> renderPointAsPhrase (blockPoint hdr) + FallingEdge -> "Set tentative header to " <> renderPointAsPhrase (blockPoint hdr) + forHuman (ChainDB.TrapTentativeHeader hdr) = + "Discovered trap tentative header " <> renderPointAsPhrase (blockPoint hdr) + forHuman (ChainDB.OutdatedTentativeHeader hdr) = + "Tentative header is now outdated " <> renderPointAsPhrase (blockPoint hdr) + + forMachine dtals (ChainDB.SetTentativeHeader hdr enclosing) = + mconcat $ + [ "kind" .= String "SetTentativeHeader" + , "block" .= renderPointForDetails dtals (blockPoint hdr) + ] + <> ["risingEdge" .= True | RisingEdge <- [enclosing]] + forMachine dtals (ChainDB.TrapTentativeHeader hdr) = + mconcat + [ "kind" .= String "TrapTentativeHeader" + , "block" .= renderPointForDetails dtals (blockPoint hdr) + ] + forMachine dtals (ChainDB.OutdatedTentativeHeader hdr) = + mconcat + [ "kind" .= String "OutdatedTentativeHeader" + , "block" .= renderPointForDetails dtals (blockPoint hdr) + ] + +instance MetaTrace (ChainDB.TracePipeliningEvent blk) where + namespaceFor ChainDB.SetTentativeHeader{} = + Namespace [] ["SetTentativeHeader"] + namespaceFor ChainDB.TrapTentativeHeader{} = + Namespace [] ["TrapTentativeHeader"] + namespaceFor ChainDB.OutdatedTentativeHeader{} = + Namespace [] ["OutdatedTentativeHeader"] + + severityFor (Namespace _ ["SetTentativeHeader"]) _ = Just Debug + severityFor (Namespace _ ["TrapTentativeHeader"]) _ = Just Debug + severityFor (Namespace _ ["OutdatedTentativeHeader"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["SetTentativeHeader"]) = + Just + "A new tentative header got set" + documentFor (Namespace _ ["TrapTentativeHeader"]) = + Just + "The body of tentative block turned out to be invalid." + documentFor (Namespace _ ["OutdatedTentativeHeader"]) = + Just + "We selected a new (better) chain, which cleared the previous tentative header." + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["SetTentativeHeader"] + , Namespace [] ["TrapTentativeHeader"] + , Namespace [] ["OutdatedTentativeHeader"] + ] + +addedHdrsNewChain :: + HasHeader (Header blk) => + AF.AnchoredFragment (Header blk) -> + AF.AnchoredFragment (Header blk) -> + [Header blk] +addedHdrsNewChain fro to_ = + case AF.intersect fro to_ of + Just (_, _, _, s2 :: AF.AnchoredFragment (Header blk)) -> + AF.toOldestFirst s2 + Nothing -> [] -- No sense to do validation here. + +-------------------------------------------------------------------------------- +-- ChainDB TraceFollowerEvent +-------------------------------------------------------------------------------- + +instance + (ConvertRawHash blk, StandardHash blk) => + LogFormatting (ChainDB.TraceFollowerEvent blk) + where + forHuman ChainDB.NewFollower = "A new Follower was created" + forHuman (ChainDB.FollowerNoLongerInMem _rrs) = + mconcat + [ "The follower was in the 'FollowerInMem' state but its point is no longer on" + , " the in-memory chain fragment, so it has to switch to the" + , " 'FollowerInImmutableDB' state" + ] + forHuman (ChainDB.FollowerSwitchToMem point slot) = + mconcat + [ "The follower was in the 'FollowerInImmutableDB' state and is switched to" + , " the 'FollowerInMem' state. Point: " <> showT point <> " slot: " <> showT slot + ] + forHuman (ChainDB.FollowerNewImmIterator point slot) = + mconcat + [ "The follower is in the 'FollowerInImmutableDB' state but the iterator is" + , " exhausted while the ImmDB has grown, so we open a new iterator to" + , " stream these blocks too. Point: " <> showT point <> " slot: " <> showT slot + ] + + forMachine _dtal ChainDB.NewFollower = + mconcat ["kind" .= String "NewFollower"] + forMachine _dtal (ChainDB.FollowerNoLongerInMem _) = + mconcat ["kind" .= String "FollowerNoLongerInMem"] + forMachine _dtal (ChainDB.FollowerSwitchToMem _ _) = + mconcat ["kind" .= String "FollowerSwitchToMem"] + forMachine _dtal (ChainDB.FollowerNewImmIterator _ _) = + mconcat ["kind" .= String "FollowerNewImmIterator"] + +instance MetaTrace (ChainDB.TraceFollowerEvent blk) where + namespaceFor ChainDB.NewFollower = + Namespace [] ["NewFollower"] + namespaceFor ChainDB.FollowerNoLongerInMem{} = + Namespace [] ["FollowerNoLongerInMem"] + namespaceFor ChainDB.FollowerSwitchToMem{} = + Namespace [] ["FollowerSwitchToMem"] + namespaceFor ChainDB.FollowerNewImmIterator{} = + Namespace [] ["FollowerNewImmIterator"] + + severityFor (Namespace _ ["NewFollower"]) _ = Just Debug + severityFor (Namespace _ ["FollowerNoLongerInMem"]) _ = Just Debug + severityFor (Namespace _ ["FollowerSwitchToMem"]) _ = Just Debug + severityFor (Namespace _ ["FollowerNewImmIterator"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["NewFollower"]) = + Just + "A new follower was created." + documentFor (Namespace _ ["FollowerNoLongerInMem"]) = + Just $ + mconcat + [ "The follower was in 'FollowerInMem' state and is switched to" + , " the 'FollowerInImmutableDB' state." + ] + documentFor (Namespace _ ["FollowerSwitchToMem"]) = + Just $ + mconcat + [ "The follower was in the 'FollowerInImmutableDB' state and is switched to" + , " the 'FollowerInMem' state." + ] + documentFor (Namespace _ ["FollowerNewImmIterator"]) = + Just $ + mconcat + [ "The follower is in the 'FollowerInImmutableDB' state but the iterator is" + , " exhausted while the ImmDB has grown, so we open a new iterator to" + , " stream these blocks too." + ] + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["NewFollower"] + , Namespace [] ["FollowerNoLongerInMem"] + , Namespace [] ["FollowerSwitchToMem"] + , Namespace [] ["FollowerNewImmIterator"] + ] + +-------------------------------------------------------------------------------- +-- ChainDB TraceCopyToImmutableDB +-------------------------------------------------------------------------------- + +instance + ConvertRawHash blk => + LogFormatting (ChainDB.TraceCopyToImmutableDBEvent blk) + where + forHuman (ChainDB.CopiedBlockToImmutableDB pt) = + "Copied block " <> renderPointAsPhrase pt <> " to the ImmDB" + forHuman ChainDB.NoBlocksToCopyToImmutableDB = + "There are no blocks to copy to the ImmDB" + + forMachine dtals (ChainDB.CopiedBlockToImmutableDB pt) = + mconcat + [ "kind" .= String "CopiedBlockToImmutableDB" + , "slot" .= forMachine dtals pt + ] + forMachine _dtals ChainDB.NoBlocksToCopyToImmutableDB = + mconcat ["kind" .= String "NoBlocksToCopyToImmutableDB"] + +instance MetaTrace (ChainDB.TraceCopyToImmutableDBEvent blk) where + namespaceFor ChainDB.CopiedBlockToImmutableDB{} = + Namespace [] ["CopiedBlockToImmutableDB"] + namespaceFor ChainDB.NoBlocksToCopyToImmutableDB{} = + Namespace [] ["NoBlocksToCopyToImmutableDB"] + + severityFor (Namespace _ ["CopiedBlockToImmutableDB"]) _ = Just Debug + severityFor (Namespace _ ["NoBlocksToCopyToImmutableDB"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["CopiedBlockToImmutableDB"]) = + Just + "A block was successfully copied to the ImmDB." + documentFor (Namespace _ ["NoBlocksToCopyToImmutableDB"]) = + Just + "There are no block to copy to the ImmDB." + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["CopiedBlockToImmutableDB"] + , Namespace [] ["NoBlocksToCopyToImmutableDB"] + ] + +-- -------------------------------------------------------------------------------- +-- -- ChainDB GCEvent +-- -------------------------------------------------------------------------------- + +instance LogFormatting (ChainDB.TraceGCEvent blk) where + forHuman (ChainDB.PerformedGC slot) = + "Performed a garbage collection for " <> condenseT slot + forHuman (ChainDB.ScheduledGC slot _difft) = + "Scheduled a garbage collection for " <> condenseT slot + + forMachine dtals (ChainDB.PerformedGC slot) = + mconcat + [ "kind" .= String "PerformedGC" + , "slot" .= forMachine dtals slot + ] + forMachine dtals (ChainDB.ScheduledGC slot difft) = + mconcat $ + [ "kind" .= String "ScheduledGC" + , "slot" .= forMachine dtals slot + ] + <> ["difft" .= String ((Text.pack . show) difft) | dtals >= DDetailed] + +instance MetaTrace (ChainDB.TraceGCEvent blk) where + namespaceFor ChainDB.PerformedGC{} = + Namespace [] ["PerformedGC"] + namespaceFor ChainDB.ScheduledGC{} = + Namespace [] ["ScheduledGC"] + + severityFor (Namespace _ ["PerformedGC"]) _ = Just Debug + severityFor (Namespace _ ["ScheduledGC"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["PerformedGC"]) = + Just + "A garbage collection for the given 'SlotNo' was performed." + documentFor (Namespace _ ["ScheduledGC"]) = + Just $ + mconcat + [ "A garbage collection for the given 'SlotNo' was scheduled to happen" + , " at the given time." + ] + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["PerformedGC"] + , Namespace [] ["ScheduledGC"] + ] + +-- -------------------------------------------------------------------------------- +-- -- TraceInitChainSelEvent +-- -------------------------------------------------------------------------------- + +instance + ( ConvertRawHash blk + , ConvertRawHash (Header blk) + , LedgerSupportsProtocol blk + , Show (PerasError blk) + ) => + LogFormatting (ChainDB.TraceInitChainSelEvent blk) + where + forHuman (ChainDB.InitChainSelValidation v) = forHuman v + forHuman ChainDB.InitialChainSelected{} = + "Initial chain selected" + forHuman ChainDB.StartedInitChainSelection{} = + "Started initial chain selection" + + forMachine dtal (ChainDB.InitChainSelValidation v) = + forMachine dtal v + forMachine _dtal ChainDB.InitialChainSelected = + mconcat ["kind" .= String "Follower.InitialChainSelected"] + forMachine _dtal ChainDB.StartedInitChainSelection = + mconcat ["kind" .= String "Follower.StartedInitChainSelection"] + + asMetrics (ChainDB.InitChainSelValidation v) = asMetrics v + asMetrics ChainDB.InitialChainSelected = [] + asMetrics ChainDB.StartedInitChainSelection = [] + +instance MetaTrace (ChainDB.TraceInitChainSelEvent blk) where + namespaceFor ChainDB.InitialChainSelected{} = + Namespace [] ["InitialChainSelected"] + namespaceFor ChainDB.StartedInitChainSelection{} = + Namespace [] ["StartedInitChainSelection"] + namespaceFor (ChainDB.InitChainSelValidation ev') = + nsPrependInner "Validation" (namespaceFor ev') + + severityFor (Namespace _ ["InitialChainSelected"]) _ = Just Info + severityFor (Namespace _ ["StartedInitChainSelection"]) _ = Just Info + severityFor + (Namespace out ("Validation" : tl)) + (Just (ChainDB.InitChainSelValidation ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("Validation" : tl)) Nothing = + severityFor + ( Namespace out tl :: + Namespace (ChainDB.TraceValidationEvent blk) + ) + Nothing + severityFor _ _ = Nothing + + privacyFor + (Namespace out ("Validation" : tl)) + (Just (ChainDB.InitChainSelValidation ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("Validation" : tl)) Nothing = + privacyFor + ( Namespace out tl :: + Namespace (ChainDB.TraceValidationEvent blk) + ) + Nothing + privacyFor _ _ = Just Public + + detailsFor + (Namespace out ("Validation" : tl)) + (Just (ChainDB.InitChainSelValidation ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("Validation" : tl)) Nothing = + detailsFor + ( Namespace out tl :: + Namespace (ChainDB.TraceValidationEvent blk) + ) + Nothing + detailsFor _ _ = Just DNormal + + metricsDocFor (Namespace out ("Validation" : tl)) = + metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceValidationEvent blk)) + metricsDocFor _ = [] + + documentFor (Namespace _ ["InitialChainSelected"]) = + Just + "A garbage collection for the given 'SlotNo' was performed." + documentFor (Namespace _ ["StartedInitChainSelection"]) = + Just $ + mconcat + [ "A garbage collection for the given 'SlotNo' was scheduled to happen" + , " at the given time." + ] + documentFor (Namespace o ("Validation" : tl)) = + documentFor (Namespace o tl :: Namespace (ChainDB.TraceValidationEvent blk)) + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["InitialChainSelected"] + , Namespace [] ["StartedInitChainSelection"] + ] + ++ map + (nsPrependInner "Validation") + (allNamespaces :: [Namespace (ChainDB.TraceValidationEvent blk)]) + +-------------------------------------------------------------------------------- +-- ChainDB TraceValidationEvent +-------------------------------------------------------------------------------- + +instance + ( LedgerSupportsProtocol blk + , ConvertRawHash (Header blk) + , ConvertRawHash blk + , LogFormatting (RealPoint blk) + , Show (PerasError blk) + ) => + LogFormatting (ChainDB.TraceValidationEvent blk) + where + forHuman (ChainDB.InvalidBlock err pt) = + "Invalid block " <> renderRealPointAsPhrase pt <> ": " <> showT err + forHuman (ChainDB.ValidCandidate c) = + "Valid candidate " <> renderPointAsPhrase (AF.headPoint c) + forHuman + ( ChainDB.UpdateLedgerDbTraceEvent + ( LedgerDB.StartedPushingBlockToTheLedgerDb + (LedgerDB.PushStart start) + (LedgerDB.PushGoal goal) + (LedgerDB.Pushing curr) + ) + ) = + let fromSlot = unSlotNo $ realPointSlot start + atSlot = unSlotNo $ realPointSlot curr + atDiff = atSlot - fromSlot + toSlot = unSlotNo $ realPointSlot goal + toDiff = toSlot - fromSlot + in "Pushing ledger state for block " + <> renderRealPointAsPhrase curr + <> ". Progress: " + <> showProgressT (fromIntegral atDiff) (fromIntegral toDiff) + <> "%" + + forMachine dtal (ChainDB.InvalidBlock err pt) = + mconcat + [ "kind" .= String "InvalidBlock" + , "block" .= forMachine dtal pt + , "error" .= showT err + ] + forMachine dtal (ChainDB.ValidCandidate c) = + mconcat + [ "kind" .= String "ValidCandidate" + , "block" .= renderPointForDetails dtal (AF.headPoint c) + ] + forMachine + _dtal + ( ChainDB.UpdateLedgerDbTraceEvent + ( LedgerDB.StartedPushingBlockToTheLedgerDb + (LedgerDB.PushStart start) + (LedgerDB.PushGoal goal) + (LedgerDB.Pushing curr) + ) + ) = + mconcat + [ "kind" .= String "UpdateLedgerDbTraceEvent.StartedPushingBlockToTheLedgerDb" + , "startingBlock" .= renderRealPoint start + , "currentBlock" .= renderRealPoint curr + , "targetBlock" .= renderRealPoint goal + ] + +instance MetaTrace (ChainDB.TraceValidationEvent blk) where + namespaceFor ChainDB.ValidCandidate{} = + Namespace [] ["ValidCandidate"] + namespaceFor ChainDB.InvalidBlock{} = + Namespace [] ["InvalidBlock"] + namespaceFor ChainDB.UpdateLedgerDbTraceEvent{} = + Namespace [] ["UpdateLedgerDb"] + + severityFor (Namespace _ ["ValidCandidate"]) _ = Just Info + severityFor (Namespace _ ["InvalidBlock"]) _ = Just Error + severityFor (Namespace _ ["UpdateLedgerDb"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ValidCandidate"]) = + Just $ + mconcat + [ "An event traced during validating performed while adding a block." + , " A candidate chain was valid." + ] + documentFor (Namespace _ ["InvalidBlock"]) = + Just $ + mconcat + [ "An event traced during validating performed while adding a block." + , " A point was found to be invalid." + ] + documentFor (Namespace _ ["UpdateLedgerDb"]) = Just "" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["ValidCandidate"] + , Namespace [] ["InvalidBlock"] + , Namespace [] ["UpdateLedgerDb"] + ] + +-------------------------------------------------------------------------------- +-- TraceOpenEvent +-------------------------------------------------------------------------------- + +instance + ConvertRawHash blk => + LogFormatting (ChainDB.TraceOpenEvent blk) + where + forHuman (ChainDB.OpenedDB immTip tip') = + "Opened db with immutable tip at " + <> renderPointAsPhrase immTip + <> " and tip " + <> renderPointAsPhrase tip' + forHuman (ChainDB.ClosedDB immTip tip') = + "Closed db with immutable tip at " + <> renderPointAsPhrase immTip + <> " and tip " + <> renderPointAsPhrase tip' + forHuman (ChainDB.OpenedImmutableDB immTip chunk) = + "Opened imm db with immutable tip at " + <> renderPointAsPhrase immTip + <> " and chunk " + <> showT chunk + forHuman (ChainDB.OpenedVolatileDB mx) = + "Opened " <> case mx of + NoMaxSlotNo -> "empty Volatile DB" + MaxSlotNo mxx -> "Volatile DB with max slot seen " <> showT mxx + forHuman ChainDB.OpenedLgrDB = "Opened lgr db" + forHuman ChainDB.StartedOpeningDB = "Started opening Chain DB" + forHuman ChainDB.StartedOpeningImmutableDB = "Started opening Immutable DB" + forHuman ChainDB.StartedOpeningVolatileDB = "Started opening Volatile DB" + forHuman ChainDB.StartedOpeningLgrDB = "Started opening Ledger DB" + + forMachine dtal (ChainDB.OpenedDB immTip tip') = + mconcat + [ "kind" .= String "OpenedDB" + , "immtip" .= forMachine dtal immTip + , "tip" .= forMachine dtal tip' + ] + forMachine dtal (ChainDB.ClosedDB immTip tip') = + mconcat + [ "kind" .= String "TraceOpenEvent.ClosedDB" + , "immtip" .= forMachine dtal immTip + , "tip" .= forMachine dtal tip' + ] + forMachine dtal (ChainDB.OpenedImmutableDB immTip epoch) = + mconcat + [ "kind" .= String "OpenedImmutableDB" + , "immtip" .= forMachine dtal immTip + , "epoch" .= String ((Text.pack . show) epoch) + ] + forMachine _dtal (ChainDB.OpenedVolatileDB maxSlotN) = + mconcat + [ "kind" .= String "OpenedVolatileDB" + , "maxSlotNo" .= String (showT maxSlotN) + ] + forMachine _dtal ChainDB.OpenedLgrDB = + mconcat ["kind" .= String "OpenedLgrDB"] + forMachine _dtal ChainDB.StartedOpeningDB = + mconcat ["kind" .= String "StartedOpeningDB"] + forMachine _dtal ChainDB.StartedOpeningImmutableDB = + mconcat ["kind" .= String "StartedOpeningImmutableDB"] + forMachine _dtal ChainDB.StartedOpeningVolatileDB = + mconcat ["kind" .= String "StartedOpeningVolatileDB"] + forMachine _dtal ChainDB.StartedOpeningLgrDB = + mconcat ["kind" .= String "StartedOpeningLgrDB"] + +instance MetaTrace (ChainDB.TraceOpenEvent blk) where + namespaceFor ChainDB.OpenedDB{} = + Namespace [] ["OpenedDB"] + namespaceFor ChainDB.ClosedDB{} = + Namespace [] ["ClosedDB"] + namespaceFor ChainDB.OpenedImmutableDB{} = + Namespace [] ["OpenedImmutableDB"] + namespaceFor ChainDB.OpenedVolatileDB{} = + Namespace [] ["OpenedVolatileDB"] + namespaceFor ChainDB.OpenedLgrDB{} = + Namespace [] ["OpenedLgrDB"] + namespaceFor ChainDB.StartedOpeningDB{} = + Namespace [] ["StartedOpeningDB"] + namespaceFor ChainDB.StartedOpeningImmutableDB{} = + Namespace [] ["StartedOpeningImmutableDB"] + namespaceFor ChainDB.StartedOpeningVolatileDB{} = + Namespace [] ["StartedOpeningVolatileDB"] + namespaceFor ChainDB.StartedOpeningLgrDB{} = + Namespace [] ["StartedOpeningLgrDB"] + + severityFor (Namespace _ ["OpenedDB"]) _ = Just Info + severityFor (Namespace _ ["ClosedDB"]) _ = Just Info + severityFor (Namespace _ ["OpenedImmutableDB"]) _ = Just Info + severityFor (Namespace _ ["OpenedVolatileDB"]) _ = Just Info + severityFor (Namespace _ ["OpenedLgrDB"]) _ = Just Info + severityFor (Namespace _ ["StartedOpeningDB"]) _ = Just Info + severityFor (Namespace _ ["StartedOpeningImmutableDB"]) _ = Just Info + severityFor (Namespace _ ["StartedOpeningVolatileDB"]) _ = Just Info + severityFor (Namespace _ ["StartedOpeningLgrDB"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["OpenedDB"]) = + Just + "The ChainDB was opened." + documentFor (Namespace _ ["ClosedDB"]) = + Just + "The ChainDB was closed." + documentFor (Namespace _ ["OpenedImmutableDB"]) = + Just + "The ImmDB was opened." + documentFor (Namespace _ ["OpenedVolatileDB"]) = + Just + "The VolatileDB was opened." + documentFor (Namespace _ ["OpenedLgrDB"]) = + Just + "The LedgerDB was opened." + documentFor (Namespace _ ["StartedOpeningDB"]) = + Just + "The ChainDB is being opened." + documentFor (Namespace _ ["StartedOpeningImmutableDB"]) = + Just + "The ImmDB is being opened." + documentFor (Namespace _ ["StartedOpeningVolatileDB"]) = + Just + "The VolatileDB is being opened." + documentFor (Namespace _ ["StartedOpeningLgrDB"]) = + Just + "The LedgerDB is being opened." + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["OpenedDB"] + , Namespace [] ["ClosedDB"] + , Namespace [] ["OpenedImmutableDB"] + , Namespace [] ["OpenedVolatileDB"] + , Namespace [] ["OpenedLgrDB"] + , Namespace [] ["StartedOpeningDB"] + , Namespace [] ["StartedOpeningImmutableDB"] + , Namespace [] ["StartedOpeningVolatileDB"] + , Namespace [] ["StartedOpeningLgrDB"] + ] + +-------------------------------------------------------------------------------- +-- IteratorEvent +-------------------------------------------------------------------------------- + +instance + ( StandardHash blk + , ConvertRawHash blk + ) => + LogFormatting (ChainDB.TraceIteratorEvent blk) + where + forHuman (ChainDB.UnknownRangeRequested ev') = forHuman ev' + forHuman (ChainDB.BlockMissingFromVolatileDB realPt) = + mconcat + [ "This block is no longer in the VolatileDB because it has been garbage" + , " collected. It might now be in the ImmDB if it was part of the" + , " current chain. Block: " <> renderRealPoint realPt + ] + forHuman (ChainDB.StreamFromImmutableDB sFrom sTo) = + mconcat + [ "Stream only from the ImmDB. StreamFrom:" <> showT sFrom + , " StreamTo: " <> showT sTo + ] + forHuman (ChainDB.StreamFromBoth sFrom sTo pts) = + mconcat + [ "Stream from both the VolatileDB and the ImmDB." + , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo + , " Points: " <> showT (map renderRealPoint pts) + ] + forHuman (ChainDB.StreamFromVolatileDB sFrom sTo pts) = + mconcat + [ "Stream only from the VolatileDB." + , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo + , " Points: " <> showT (map renderRealPoint pts) + ] + forHuman (ChainDB.BlockWasCopiedToImmutableDB pt) = + mconcat + [ "This block has been garbage collected from the VolatileDB is now" + , " found and streamed from the ImmDB. Block: " <> renderRealPoint pt + ] + forHuman (ChainDB.BlockGCedFromVolatileDB pt) = + mconcat + [ "This block no longer in the VolatileDB and isn't in the ImmDB" + , " either; it wasn't part of the current chain. Block: " <> renderRealPoint pt + ] + forHuman ChainDB.SwitchBackToVolatileDB = "SwitchBackToVolatileDB" + + forMachine _dtal (ChainDB.UnknownRangeRequested unkRange) = + mconcat + [ "kind" .= String "UnknownRangeRequested" + , "range" .= String (showT unkRange) + ] + forMachine _dtal (ChainDB.StreamFromVolatileDB streamFrom streamTo realPt) = + mconcat + [ "kind" .= String "StreamFromVolatileDB" + , "from" .= String (showT streamFrom) + , "to" .= String (showT streamTo) + , "point" .= String (Text.pack . show $ map renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.StreamFromImmutableDB streamFrom streamTo) = + mconcat + [ "kind" .= String "StreamFromImmutableDB" + , "from" .= String (showT streamFrom) + , "to" .= String (showT streamTo) + ] + forMachine _dtal (ChainDB.StreamFromBoth streamFrom streamTo realPt) = + mconcat + [ "kind" .= String "StreamFromBoth" + , "from" .= String (showT streamFrom) + , "to" .= String (showT streamTo) + , "point" .= String (Text.pack . show $ map renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.BlockMissingFromVolatileDB realPt) = + mconcat + [ "kind" .= String "BlockMissingFromVolatileDB" + , "point" .= String (renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.BlockWasCopiedToImmutableDB realPt) = + mconcat + [ "kind" .= String "BlockWasCopiedToImmutableDB" + , "point" .= String (renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.BlockGCedFromVolatileDB realPt) = + mconcat + [ "kind" .= String "BlockGCedFromVolatileDB" + , "point" .= String (renderRealPoint realPt) + ] + forMachine _dtal ChainDB.SwitchBackToVolatileDB = + mconcat + [ "kind" .= String "SwitchBackToVolatileDB" + ] + +instance MetaTrace (ChainDB.TraceIteratorEvent blk) where + namespaceFor (ChainDB.UnknownRangeRequested ur) = + nsPrependInner "UnknownRangeRequested" (namespaceFor ur) + namespaceFor ChainDB.StreamFromVolatileDB{} = + Namespace [] ["StreamFromVolatileDB"] + namespaceFor ChainDB.StreamFromImmutableDB{} = + Namespace [] ["StreamFromImmutableDB"] + namespaceFor ChainDB.StreamFromBoth{} = + Namespace [] ["StreamFromBoth"] + namespaceFor ChainDB.BlockMissingFromVolatileDB{} = + Namespace [] ["BlockMissingFromVolatileDB"] + namespaceFor ChainDB.BlockWasCopiedToImmutableDB{} = + Namespace [] ["BlockWasCopiedToImmutableDB"] + namespaceFor ChainDB.BlockGCedFromVolatileDB{} = + Namespace [] ["BlockGCedFromVolatileDB"] + namespaceFor ChainDB.SwitchBackToVolatileDB{} = + Namespace [] ["SwitchBackToVolatileDB"] + + severityFor + (Namespace out ("UnknownRangeRequested" : tl)) + (Just (ChainDB.UnknownRangeRequested ur)) = + severityFor (Namespace out tl) (Just ur) + severityFor (Namespace out ("UnknownRangeRequested" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.UnknownRange blk)) Nothing + severityFor _ _ = Just Debug + + privacyFor + (Namespace out ("UnknownRangeRequested" : tl)) + (Just (ChainDB.UnknownRangeRequested ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("UnknownRangeRequested" : tl)) Nothing = + privacyFor + ( Namespace out tl :: + Namespace (ChainDB.UnknownRange blk) + ) + Nothing + privacyFor _ _ = Just Public + + detailsFor + (Namespace out ("UnknownRangeRequested" : tl)) + (Just (ChainDB.UnknownRangeRequested ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("UnknownRangeRequested" : tl)) Nothing = + detailsFor + ( Namespace out tl :: + Namespace (ChainDB.UnknownRange blk) + ) + Nothing + detailsFor _ _ = Just DNormal + + documentFor (Namespace out ("UnknownRangeRequested" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.UnknownRange blk)) + documentFor (Namespace _ ["StreamFromVolatileDB"]) = + Just + "Stream only from the VolatileDB." + documentFor (Namespace _ ["StreamFromImmutableDB"]) = + Just + "Stream only from the ImmDB." + documentFor (Namespace _ ["StreamFromBoth"]) = + Just + "Stream from both the VolatileDB and the ImmDB." + documentFor (Namespace _ ["BlockMissingFromVolatileDB"]) = + Just $ + mconcat + [ "A block is no longer in the VolatileDB because it has been garbage" + , " collected. It might now be in the ImmDB if it was part of the" + , " current chain." + ] + documentFor (Namespace _ ["BlockWasCopiedToImmutableDB"]) = + Just $ + mconcat + [ "A block that has been garbage collected from the VolatileDB is now" + , " found and streamed from the ImmDB." + ] + documentFor (Namespace _ ["BlockGCedFromVolatileDB"]) = + Just $ + mconcat + [ "A block is no longer in the VolatileDB and isn't in the ImmDB" + , " either; it wasn't part of the current chain." + ] + documentFor (Namespace _ ["SwitchBackToVolatileDB"]) = + Just $ + mconcat + [ "We have streamed one or more blocks from the ImmDB that were part" + , " of the VolatileDB when initialising the iterator. Now, we have to look" + , " back in the VolatileDB again because the ImmDB doesn't have the" + , " next block we're looking for." + ] + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["StreamFromVolatileDB"] + , Namespace [] ["StreamFromImmutableDB"] + , Namespace [] ["StreamFromBoth"] + , Namespace [] ["BlockMissingFromVolatileDB"] + , Namespace [] ["BlockWasCopiedToImmutableDB"] + , Namespace [] ["BlockGCedFromVolatileDB"] + , Namespace [] ["SwitchBackToVolatileDB"] + ] + ++ map + (nsPrependInner "UnknownRangeRequested") + (allNamespaces :: [Namespace (ChainDB.UnknownRange blk)]) + +-------------------------------------------------------------------------------- +-- UnknownRange +-------------------------------------------------------------------------------- + +instance + ( StandardHash blk + , ConvertRawHash blk + ) => + LogFormatting (ChainDB.UnknownRange blk) + where + forHuman (ChainDB.MissingBlock realPt) = + "The block at the given point was not found in the ChainDB." + <> renderRealPoint realPt + forHuman (ChainDB.ForkTooOld streamFrom) = + "The requested range forks off too far in the past" + <> showT streamFrom + + forMachine _dtal (ChainDB.MissingBlock realPt) = + mconcat + [ "kind" .= String "MissingBlock" + , "point" .= String (renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.ForkTooOld streamFrom) = + mconcat + [ "kind" .= String "ForkTooOld" + , "from" .= String (showT streamFrom) + ] + +instance MetaTrace (ChainDB.UnknownRange blk) where + namespaceFor ChainDB.MissingBlock{} = Namespace [] ["MissingBlock"] + namespaceFor ChainDB.ForkTooOld{} = Namespace [] ["ForkTooOld"] + + severityFor _ _ = Just Debug + + documentFor (Namespace _ ["MissingBlock"]) = + Just + "" + documentFor (Namespace _ ["ForkTooOld"]) = + Just + "" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["MissingBlock"] + , Namespace [] ["ForkTooOld"] + ] + +-- -------------------------------------------------------------------------------- +-- -- Peras +-- -------------------------------------------------------------------------------- + +instance MetaTrace (PerasVoteDB.TraceEvent blk) where + namespaceFor (PerasVoteDB.AddVote{}) = Namespace [] ["AddVote"] + namespaceFor (PerasVoteDB.GarbageCollected{}) = Namespace [] ["GarbageCollected"] + allNamespaces = + [ Namespace [] ["AddVote"] + , Namespace [] ["GarbageCollected"] + ] + + severityFor _ _ = Just Info + privacyFor _ _ = Just Public + detailsFor _ _ = Just DNormal + + documentFor (Namespace _ ["AddVote"]) = Just "AddVote" + documentFor (Namespace _ ["GarbageCollected"]) = Just "GarbageCollected" + documentFor _ = Nothing + +instance Show (PerasCert blk) => LogFormatting (PerasVoteDB.TraceEvent blk) where + forHuman (PerasVoteDB.AddVote voteId _vote result) = + "Peras vote " <> Text.pack (show voteId) <> ": " <> Text.pack (show result) + forHuman (PerasVoteDB.GarbageCollected slotNo) = + "Peras vote DB garbage collected at slot " <> Text.pack (show slotNo) + + forMachine _dtal (PerasVoteDB.AddVote voteId _vote result) = + mconcat + [ "kind" .= String "AddVote" + , "voteId" .= String (Text.pack $ show voteId) + , "result" .= String (Text.pack $ show result) + ] + forMachine _dtal (PerasVoteDB.GarbageCollected slotNo) = + mconcat + [ "kind" .= String "GarbageCollected" + , "slot" .= String (Text.pack $ show slotNo) + ] + + asMetrics _ = [] + +instance MetaTrace (PerasCertDB.TraceEvent blk) where + namespaceFor (PerasCertDB.AddCert{}) = Namespace [] ["AddCert"] + namespaceFor (PerasCertDB.GarbageCollected _) = Namespace [] ["GarbageCollected"] + allNamespaces = + [ Namespace [] ["AddCert"] + , Namespace [] ["GarbageCollected"] + ] + + severityFor _ _ = Just Info + privacyFor _ _ = Just Public + detailsFor _ _ = Just DNormal + + documentFor (Namespace _ ["AddCert"]) = Just "AddCert" + documentFor (Namespace _ ["GarbageCollected"]) = Just "GarbageCollected" + documentFor _ = Nothing + +instance LogFormatting (PerasCertDB.TraceEvent blk) where + forHuman (PerasCertDB.AddCert roundNo _cert result) = + "Peras certificate for round " <> Text.pack (show roundNo) <> ": " <> Text.pack (show result) + forHuman (PerasCertDB.GarbageCollected slotNo) = + "Peras certificate DB garbage collected at slot " <> Text.pack (show slotNo) + + forMachine _dtal (PerasCertDB.AddCert roundNo _cert result) = + mconcat + [ "kind" .= String "AddCert" + , "round" .= String (Text.pack $ show roundNo) + , "result" .= String (Text.pack $ show result) + ] + forMachine _dtal (PerasCertDB.GarbageCollected slotNo) = + mconcat + [ "kind" .= String "GarbageCollected" + , "slot" .= String (Text.pack $ show slotNo) + ] + + asMetrics _ = [] + +-- -------------------------------------------------------------------------------- +-- -- LedgerDB.TraceEvent +-- -------------------------------------------------------------------------------- + +instance + ( StandardHash blk + , ConvertRawHash blk + ) => + LogFormatting (LedgerDB.TraceEvent blk) + where + forMachine dtals (LedgerDB.LedgerDBSnapshotEvent ev) = forMachine dtals ev + forMachine dtals (LedgerDB.LedgerReplayEvent ev) = forMachine dtals ev + forMachine dtals (LedgerDB.LedgerDBForkerEvent ev) = forMachine dtals ev + forMachine dtals (LedgerDB.LedgerDBFlavorImplEvent ev) = forMachine dtals ev + + forHuman (LedgerDB.LedgerDBSnapshotEvent ev) = forHuman ev + forHuman (LedgerDB.LedgerReplayEvent ev) = forHuman ev + forHuman (LedgerDB.LedgerDBForkerEvent ev) = forHuman ev + forHuman (LedgerDB.LedgerDBFlavorImplEvent ev) = forHuman ev + +instance MetaTrace (LedgerDB.TraceEvent blk) where + namespaceFor (LedgerDB.LedgerDBSnapshotEvent ev) = + nsPrependInner "Snapshot" (namespaceFor ev) + namespaceFor (LedgerDB.LedgerReplayEvent ev) = + nsPrependInner "Replay" (namespaceFor ev) + namespaceFor (LedgerDB.LedgerDBForkerEvent ev) = + nsPrependInner "Forker" (namespaceFor ev) + namespaceFor (LedgerDB.LedgerDBFlavorImplEvent ev) = + nsPrependInner "Flavor" (namespaceFor ev) + + severityFor (Namespace out ("Snapshot" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) Nothing + severityFor (Namespace out ("Snapshot" : tl)) (Just (LedgerDB.LedgerDBSnapshotEvent ev)) = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) (Just ev) + severityFor (Namespace out ("Replay" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) Nothing + severityFor (Namespace out ("Replay" : tl)) (Just (LedgerDB.LedgerReplayEvent ev)) = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) (Just ev) + severityFor (Namespace out ("Forker" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace LedgerDB.TraceForkerEventWithKey) Nothing + severityFor (Namespace out ("Forker" : tl)) (Just (LedgerDB.LedgerDBForkerEvent ev)) = + severityFor (Namespace out tl :: Namespace LedgerDB.TraceForkerEventWithKey) (Just ev) + severityFor (Namespace out ("Flavor" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace LedgerDB.FlavorImplSpecificTrace) Nothing + severityFor (Namespace out ("Flavor" : tl)) (Just (LedgerDB.LedgerDBFlavorImplEvent ev)) = + severityFor (Namespace out tl :: Namespace LedgerDB.FlavorImplSpecificTrace) (Just ev) + severityFor _ _ = Nothing + + documentFor (Namespace o ("Snapshot" : tl)) = + documentFor (Namespace o tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) + documentFor (Namespace o ("Replay" : tl)) = + documentFor (Namespace o tl :: Namespace (LedgerDB.TraceReplayEvent blk)) + documentFor (Namespace o ("Forker" : tl)) = + documentFor (Namespace o tl :: Namespace LedgerDB.TraceForkerEventWithKey) + documentFor (Namespace o ("Flavor" : tl)) = + documentFor (Namespace o tl :: Namespace LedgerDB.FlavorImplSpecificTrace) + documentFor _ = Nothing + + allNamespaces = + map + (nsPrependInner "Snapshot") + (allNamespaces :: [Namespace (LedgerDB.TraceSnapshotEvent blk)]) + ++ map + (nsPrependInner "Replay") + (allNamespaces :: [Namespace (LedgerDB.TraceReplayEvent blk)]) + ++ map + (nsPrependInner "Forker") + (allNamespaces :: [Namespace LedgerDB.TraceForkerEventWithKey]) + ++ map + (nsPrependInner "Flavor") + (allNamespaces :: [Namespace LedgerDB.FlavorImplSpecificTrace]) + +instance + ( StandardHash blk + , ConvertRawHash blk + ) => + LogFormatting (LedgerDB.TraceSnapshotEvent blk) + where + forHuman (LedgerDB.SnapshotRequestDelayed _snapshotRequestTime delayBeforeSnapshotting slots) = + Text.unwords + [ "Scheduling to take ledger state snapshots at slots " + , showT (NonEmpty.toList slots) + , ", with a randomised delay of" + , showT delayBeforeSnapshotting + ] + forHuman LedgerDB.SnapshotRequestCompleted = "Completed taking a ledger state snapshot" + forHuman (LedgerDB.TookSnapshot snap pt RisingEdge) = + Text.unwords + [ "Taking ledger snapshot" + , showT snap + , "at" + , renderRealPointAsPhrase pt + ] + forHuman (LedgerDB.TookSnapshot snap pt (FallingEdgeWith t)) = + Text.unwords + [ "Took ledger snapshot" + , showT snap + , "at" + , renderRealPointAsPhrase pt + , ", duration:" + , showT t + ] + forHuman (LedgerDB.DeletedSnapshot snap) = + Text.unwords ["Deleted old snapshot", showT snap] + forHuman (LedgerDB.InvalidSnapshot snap failure) = + Text.unwords + [ "Invalid snapshot" + , showT snap + , showT failure + , context + ] + where + context = case failure of + LedgerDB.InitFailureRead LedgerDB.ReadSnapshotFailed{} -> + " This is most likely an expected change in the serialization format," + <> " which currently requires a chain replay" + LedgerDB.InitFailureRead LedgerDB.ReadSnapshotDataCorruption -> + " The snapshot fails the CRC check. It seems there has been disk corruption" + LedgerDB.InitFailureRead (LedgerDB.ReadMetadataError _ err) -> case err of + LedgerDB.MetadataFileDoesNotExist -> + " The snapshot doesn't have the required metadata file." + LedgerDB.MetadataInvalid errMsg -> + " Snapshot metadata file failed to deserialize: " <> showT errMsg + LedgerDB.MetadataBackendMismatch -> + " Snapshot was created for a different backend. Convert it with `snapshot-converter`." + _ -> "" + + forMachine _dtals (LedgerDB.SnapshotRequestDelayed snapshotRequestTime delayBeforeSnapshotting slots) = + mconcat + [ "kind" .= String "SnapshotRequestDelayed" + , "requestTime" .= show snapshotRequestTime + , "delayBeforeSnapshotting" .= show delayBeforeSnapshotting + , "slots" .= toJSON (NonEmpty.toList slots) + ] + forMachine _dtals LedgerDB.SnapshotRequestCompleted = + mconcat + [ "kind" .= String "SnapshotRequestCompleted" + ] + forMachine dtals (LedgerDB.TookSnapshot snap pt enclosedTiming) = + mconcat + [ "kind" .= String "TookSnapshot" + , "snapshot" .= forMachine dtals snap + , "tip" .= show pt + , "enclosedTime" .= enclosingValue enclosedTiming + ] + forMachine dtals (LedgerDB.DeletedSnapshot snap) = + mconcat + [ "kind" .= String "DeletedSnapshot" + , "snapshot" .= forMachine dtals snap + ] + forMachine dtals (LedgerDB.InvalidSnapshot snap failure) = + mconcat + [ "kind" .= String "InvalidSnapshot" + , "snapshot" .= forMachine dtals snap + , "failure" .= show failure + ] + +instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where + namespaceFor LedgerDB.SnapshotRequestDelayed{} = Namespace [] ["SnapshotRequestDelayed"] + namespaceFor LedgerDB.SnapshotRequestCompleted{} = Namespace [] ["SnapshotRequestCompleted"] + namespaceFor LedgerDB.TookSnapshot{} = Namespace [] ["TookSnapshot"] + namespaceFor LedgerDB.DeletedSnapshot{} = Namespace [] ["DeletedSnapshot"] + namespaceFor LedgerDB.InvalidSnapshot{} = Namespace [] ["InvalidSnapshot"] + + severityFor (Namespace _ ["SnapshotRequestDelayed"]) _ = Just Debug + severityFor (Namespace _ ["SnapshotRequestCompleted"]) _ = Just Debug + severityFor (Namespace _ ["TookSnapshot"]) _ = Just Info + severityFor (Namespace _ ["DeletedSnapshot"]) _ = Just Debug + severityFor (Namespace _ ["InvalidSnapshot"]) _ = Just Error + severityFor _ _ = Nothing + + documentFor (Namespace _ ["TookSnapshot"]) = + Just $ + mconcat + [ "A snapshot is being written to disk. Two events will be traced, one" + , " for when the node starts taking the snapshot and another one for" + , " when the snapshot has been written to the disk." + ] + documentFor (Namespace _ ["DeletedSnapshot"]) = + Just + "A snapshot was deleted from the disk." + documentFor (Namespace _ ["InvalidSnapshot"]) = + Just $ + mconcat + [ "An on disk snapshot was invalid. Unless it was suffixed or" + , " seems to be from an old node or different backend, it will" + , " be deleted" + ] + documentFor (Namespace _ ["SnapshotRequestDelayed"]) = + Just + "A delayed snapshot request was issued. The snapshot will be initiated at the specified timestamp, with the specified delay and for the specified slots" + documentFor (Namespace _ ["SnapshotRequestCompleted"]) = + Just + "The delayed snapshot request was completed" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["TookSnapshot"] + , Namespace [] ["DeletedSnapshot"] + , Namespace [] ["InvalidSnapshot"] + , Namespace [] ["SnapshotRequestDelayed"] + , Namespace [] ["SnapshotRequestCompleted"] + ] + +-------------------------------------------------------------------------------- +-- LedgerDB TraceReplayEvent +-------------------------------------------------------------------------------- + +instance + (StandardHash blk, ConvertRawHash blk) => + LogFormatting (LedgerDB.TraceReplayEvent blk) + where + forHuman (LedgerDB.TraceReplayStartEvent ev') = forHuman ev' + forHuman (LedgerDB.TraceReplayProgressEvent ev') = forHuman ev' + + forMachine dtal (LedgerDB.TraceReplayStartEvent ev') = forMachine dtal ev' + forMachine dtal (LedgerDB.TraceReplayProgressEvent ev') = forMachine dtal ev' + +instance + (StandardHash blk, ConvertRawHash blk) => + LogFormatting (LedgerDB.TraceReplayStartEvent blk) + where + forHuman LedgerDB.ReplayFromGenesis = + "Replaying ledger from genesis" + forHuman (LedgerDB.ReplayFromSnapshot snap (LedgerDB.ReplayStart tip')) = + "Replaying ledger from snapshot " + <> showT snap + <> " at " + <> renderPointAsPhrase tip' + + forMachine _dtal LedgerDB.ReplayFromGenesis = + mconcat ["kind" .= String "ReplayFromGenesis"] + forMachine dtal (LedgerDB.ReplayFromSnapshot snap tip') = + mconcat + [ "kind" .= String "ReplayFromSnapshot" + , "snapshot" .= forMachine dtal snap + , "tip" .= showT tip' + ] + +instance + (StandardHash blk, ConvertRawHash blk) => + LogFormatting (LedgerDB.TraceReplayProgressEvent blk) + where + forHuman + ( LedgerDB.ReplayedBlock + pt + _ledgerEvents + (LedgerDB.ReplayStart replayFrom) + (LedgerDB.ReplayGoal replayTo) + ) = + let fromSlot = withOrigin 0 id $ unSlotNo <$> pointSlot replayFrom + atSlot = unSlotNo $ realPointSlot pt + atDiff = atSlot - fromSlot + toSlot = withOrigin 0 id $ unSlotNo <$> pointSlot replayTo + toDiff = toSlot - fromSlot + in "Replayed block: slot " + <> showT atSlot + <> " out of " + <> showT toSlot + <> ". Progress: " + <> showProgressT (fromIntegral atDiff) (fromIntegral toDiff) + <> "%" + + forMachine + _dtal + ( LedgerDB.ReplayedBlock + pt + _ledgerEvents + _ + (LedgerDB.ReplayGoal replayTo) + ) = + mconcat + [ "kind" .= String "ReplayedBlock" + , "slot" .= unSlotNo (realPointSlot pt) + , "tip" .= withOrigin 0 unSlotNo (pointSlot replayTo) + ] + +instance MetaTrace (LedgerDB.TraceReplayEvent blk) where + namespaceFor (LedgerDB.TraceReplayStartEvent ev) = + nsPrependInner "ReplayStart" (namespaceFor ev) + namespaceFor (LedgerDB.TraceReplayProgressEvent ev) = + nsPrependInner "ReplayProgress" (namespaceFor ev) + + severityFor (Namespace out ("ReplayStart" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayStartEvent blk)) Nothing + severityFor (Namespace out ("ReplayStart" : tl)) (Just (LedgerDB.TraceReplayStartEvent ev)) = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayStartEvent blk)) (Just ev) + severityFor (Namespace out ("ReplayProgress" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayProgressEvent blk)) Nothing + severityFor (Namespace out ("ReplayProgress" : tl)) (Just (LedgerDB.TraceReplayProgressEvent ev)) = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayProgressEvent blk)) (Just ev) + severityFor _ _ = Nothing + + documentFor (Namespace out ("ReplayStart" : tl)) = + documentFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayStartEvent blk)) + documentFor (Namespace out ("ReplayProgress" : tl)) = + documentFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayProgressEvent blk)) + documentFor _ = Nothing + + allNamespaces = + map + (nsPrependInner "ReplayStart") + (allNamespaces :: [Namespace (LedgerDB.TraceReplayStartEvent blk)]) + ++ map + (nsPrependInner "ReplayProgress") + (allNamespaces :: [Namespace (LedgerDB.TraceReplayProgressEvent blk)]) + +instance MetaTrace (LedgerDB.TraceReplayStartEvent blk) where + namespaceFor LedgerDB.ReplayFromGenesis{} = Namespace [] ["ReplayFromGenesis"] + namespaceFor LedgerDB.ReplayFromSnapshot{} = Namespace [] ["ReplayFromSnapshot"] + + severityFor (Namespace _ ["ReplayFromGenesis"]) _ = Just Info + severityFor (Namespace _ ["ReplayFromSnapshot"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ReplayFromGenesis"]) = + Just $ + mconcat + [ "There were no LedgerDB snapshots on disk, so we're replaying all" + , " blocks starting from Genesis against the initial ledger." + , " The @replayTo@ parameter corresponds to the block at the tip of the" + , " ImmDB, i.e., the last block to replay." + ] + documentFor (Namespace _ ["ReplayFromSnapshot"]) = + Just $ + mconcat + [ "There was a LedgerDB snapshot on disk corresponding to the given tip." + , " We're replaying more recent blocks against it." + , " The @replayTo@ parameter corresponds to the block at the tip of the" + , " ImmDB, i.e., the last block to replay." + ] + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["ReplayFromGenesis"] + , Namespace [] ["ReplayFromSnapshot"] + ] + +instance MetaTrace (LedgerDB.TraceReplayProgressEvent blk) where + namespaceFor LedgerDB.ReplayedBlock{} = Namespace [] ["ReplayedBlock"] + + severityFor (Namespace _ ["ReplayedBlock"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ReplayedBlock"]) = + Just $ + mconcat + [ "We replayed the given block (reference) on the genesis snapshot" + , " during the initialisation of the LedgerDB." + , "\n" + , " The @blockInfo@ parameter corresponds replayed block and the @replayTo@" + , " parameter corresponds to the block at the tip of the ImmDB, i.e.," + , " the last block to replay." + ] + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["ReplayedBlock"] + ] + +-------------------------------------------------------------------------------- +-- Forker events +-------------------------------------------------------------------------------- + +instance LogFormatting LedgerDB.TraceForkerEventWithKey where + forMachine dtals (LedgerDB.TraceForkerEventWithKey k ev) = + (\ev' -> mconcat ["key" .= showT k, "event" .= ev']) $ forMachine dtals ev + forHuman (LedgerDB.TraceForkerEventWithKey k ev) = + "Forker " <> showT k <> ": " <> forHuman ev + +instance LogFormatting LedgerDB.TraceForkerEvent where + forMachine _dtals LedgerDB.ForkerOpen = + mconcat ["kind" .= String "ForkerOpen"] + forMachine _dtals (LedgerDB.ForkerReadTables e) = + mconcat + [ "kind" .= String "ForkerReadTables" + , "edge" .= case e of + RisingEdge -> String "RisingEdge" + FallingEdgeWith t -> toJSON t + ] + forMachine _dtals (LedgerDB.ForkerRangeReadTables e) = + mconcat + [ "kind" .= String "ForkerRangeReadTables" + , "edge" .= case e of + RisingEdge -> String "RisingEdge" + FallingEdgeWith t -> toJSON t + ] + forMachine _dtals LedgerDB.ForkerReadStatistics = mempty + forMachine _dtals (LedgerDB.ForkerPush e) = + mconcat + [ "kind" .= String "ForkerPush" + , "edge" .= case e of + RisingEdge -> String "RisingEdge" + FallingEdgeWith t -> toJSON t + ] + forMachine _dtals (LedgerDB.ForkerClose wc) = + mconcat + [ "kind" .= String "ForkerClose" + , "wasCommitted" .= toJSON (wc == LedgerDB.ForkerWasCommitted) + ] + + forHuman LedgerDB.ForkerOpen = "Opened forker" + forHuman (LedgerDB.ForkerReadTables RisingEdge) = "Forker reading tables" + forHuman (LedgerDB.ForkerReadTables (FallingEdgeWith t)) = "Forker read tables, took " <> showT t + forHuman (LedgerDB.ForkerRangeReadTables RisingEdge) = "Forker range reading tables" + forHuman (LedgerDB.ForkerRangeReadTables (FallingEdgeWith t)) = "Forker range read tables, took " <> showT t + forHuman LedgerDB.ForkerReadStatistics = "Forker gathering statistics" + forHuman (LedgerDB.ForkerPush RisingEdge) = "Forker pushing" + forHuman (LedgerDB.ForkerPush (FallingEdgeWith t)) = "Forker pushed, took " <> showT t + forHuman (LedgerDB.ForkerClose wc) = + "Closed forker, " <> case wc of + LedgerDB.ForkerWasCommitted -> "was committed" + LedgerDB.ForkerWasUncommitted -> "was discarded" + +instance MetaTrace LedgerDB.TraceForkerEventWithKey where + namespaceFor (LedgerDB.TraceForkerEventWithKey _ ev) = + nsCast $ namespaceFor ev + severityFor ns (Just (LedgerDB.TraceForkerEventWithKey _ ev)) = + severityFor (nsCast ns) (Just ev) + severityFor (Namespace out tl) Nothing = + severityFor (Namespace out tl :: Namespace LedgerDB.TraceForkerEvent) Nothing + documentFor = documentFor @LedgerDB.TraceForkerEvent . nsCast + allNamespaces = map nsCast $ allNamespaces @LedgerDB.TraceForkerEvent + +instance MetaTrace LedgerDB.TraceForkerEvent where + namespaceFor LedgerDB.ForkerOpen = Namespace [] ["Open"] + namespaceFor LedgerDB.ForkerReadTables{} = Namespace [] ["Read"] + namespaceFor LedgerDB.ForkerRangeReadTables{} = Namespace [] ["RangeRead"] + namespaceFor LedgerDB.ForkerReadStatistics = Namespace [] ["Statistics"] + namespaceFor LedgerDB.ForkerPush{} = Namespace [] ["Push"] + namespaceFor LedgerDB.ForkerClose{} = Namespace [] ["Close"] + + severityFor _ _ = Just Debug + + documentFor (Namespace _ ("Open" : _tl)) = Just "A forker is being opened" + documentFor (Namespace _ ("Read" : _tl)) = Just "A forker is reading values" + documentFor (Namespace _ ("RangeRead" : _tl)) = Just "A forker is range reading values" + documentFor (Namespace _ ("Statistics" : _tl)) = Just "Statistics were gathered from the forker" + documentFor (Namespace _ ("Push" : _tl)) = Just "A forker is pushing a new ledger state" + documentFor (Namespace _ ("Close" : _tl)) = Just "A forker was closed" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["Open"] + , Namespace [] ["Read"] + , Namespace [] ["RangeRead"] + , Namespace [] ["Statistics"] + , Namespace [] ["Push"] + , Namespace [] ["Close"] + ] + +-------------------------------------------------------------------------------- +-- Flavor specific trace +-------------------------------------------------------------------------------- + +instance LogFormatting LedgerDB.FlavorImplSpecificTrace where + forMachine dtal (LedgerDB.FlavorImplSpecificTraceV2 ev) = forMachine dtal ev + + forHuman (LedgerDB.FlavorImplSpecificTraceV2 ev) = forHuman ev + +instance MetaTrace LedgerDB.FlavorImplSpecificTrace where + namespaceFor (LedgerDB.FlavorImplSpecificTraceV2 ev) = + nsPrependInner "V2" (namespaceFor ev) + + severityFor (Namespace out ("V2" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) Nothing + severityFor (Namespace out ("V2" : tl)) (Just (LedgerDB.FlavorImplSpecificTraceV2 ev)) = + severityFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) (Just ev) + severityFor _ _ = Nothing + + documentFor (Namespace out ("V2" : tl)) = + documentFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) + documentFor _ = Nothing + + allNamespaces = + map + (nsPrependInner "V2") + (allNamespaces :: [Namespace V2.LedgerDBV2Trace]) + +{------------------------------------------------------------------------------- + V2 +-------------------------------------------------------------------------------} + +instance LogFormatting EnclosingTimed where + forMachine _dtal = enclosingObject + + forHuman RisingEdge = "Starting" + forHuman (FallingEdgeWith a) = "Completed in " <> showT a <> " seconds" + +enclosingObject :: ToJSON a => Enclosing' a -> Object +enclosingObject RisingEdge = mconcat ["edge" .= String "Starting"] +enclosingObject (FallingEdgeWith a) = mconcat ["edge" .= toJSON a] + +enclosingValue :: ToJSON a => Enclosing' a -> Value +enclosingValue = Object . enclosingObject + +instance LogFormatting V2.LedgerDBV2Trace where + forMachine dtal (V2.TraceLedgerTablesHandleCreate enc) = + mconcat ["kind" .= String "LedgerTablesHandleCreate", "enclosing" .= forMachine dtal enc] + forMachine dtal (V2.TraceLedgerTablesHandleClose enc) = + mconcat ["kind" .= String "LedgerTablesHandleClose", "enclosing" .= forMachine dtal enc] + forMachine dtal (V2.BackendTrace ev) = forMachine dtal ev + forMachine dtal (V2.TraceLedgerTablesHandleRead enc) = + mconcat ["kind" .= String "LedgerTablesHandleRead", "enclosing" .= forMachine dtal enc] + forMachine dtal (V2.TraceLedgerTablesHandleDuplicate enc) = + mconcat ["kind" .= String "LedgerTablesHandleDuplicate", "enclosing" .= forMachine dtal enc] + forMachine dtal (V2.TraceLedgerTablesHandleCreateFirst enc) = + mconcat ["kind" .= String "LedgerTablesHandleCreateFirst", "enclosing" .= forMachine dtal enc] + forMachine dtal (V2.TraceLedgerTablesHandlePush enc) = + mconcat ["kind" .= String "LedgerTablesHandlePush", "enclosing" .= forMachine dtal enc] + + forHuman (V2.TraceLedgerTablesHandleCreate enc) = "Created a new 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.TraceLedgerTablesHandleClose enc) = "Closed a 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.BackendTrace ev) = forHuman ev + forHuman (V2.TraceLedgerTablesHandleRead enc) = "Read from a 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.TraceLedgerTablesHandleDuplicate enc) = "Duplicating a 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.TraceLedgerTablesHandleCreateFirst enc) = "Creating the first 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.TraceLedgerTablesHandlePush enc) = "Pushing to 'LedgerTablesHandle': " <> forHuman enc + +instance MetaTrace V2.LedgerDBV2Trace where + namespaceFor V2.TraceLedgerTablesHandleCreate{} = + Namespace [] ["LedgerTablesHandleCreate"] + namespaceFor V2.TraceLedgerTablesHandleClose{} = + Namespace [] ["LedgerTablesHandleClose"] + namespaceFor (V2.BackendTrace ev) = nsPrependInner "BackendTrace" (namespaceFor ev) + namespaceFor V2.TraceLedgerTablesHandleRead{} = Namespace [] ["LedgerTablesHandleRead"] + namespaceFor V2.TraceLedgerTablesHandleDuplicate{} = Namespace [] ["LedgerTablesHandleDuplicate"] + namespaceFor V2.TraceLedgerTablesHandleCreateFirst{} = Namespace [] ["LedgerTablesHandleCreateFirst"] + namespaceFor V2.TraceLedgerTablesHandlePush{} = Namespace [] ["LedgerTablesHandlePush"] + + severityFor (Namespace _ ["LedgerTablesHandleCreate"]) _ = Just Debug + severityFor (Namespace _ ["LedgerTablesHandleClose"]) _ = Just Debug + severityFor (Namespace _ ["LedgerTablesHandleRead"]) _ = Just Debug + severityFor (Namespace _ ["LedgerTablesHandleDuplicate"]) _ = Just Debug + severityFor (Namespace _ ["LedgerTablesHandleCreateFirst"]) _ = Just Debug + severityFor (Namespace _ ["LedgerTablesHandlePush"]) _ = Just Debug + severityFor (Namespace _ ("BackendTrace" : _)) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["LedgerTablesHandleCreate"]) = + Just "Created a ledger tables handle" + documentFor (Namespace _ ["LedgerTablesHandleClose"]) = + Just "Closed a ledger tables handle" + documentFor (Namespace _ ["LedgerTablesHandleRead"]) = + Just "Reading from ledger tables handle" + documentFor (Namespace _ ["LedgerTablesHandlePush"]) = + Just "Pushing to a ledger tables handle" + documentFor (Namespace _ ["LedgerTablesHandleCreateFirst"]) = + Just "Creating the first ledger tables handle" + documentFor (Namespace _ ["LedgerTablesHandleDuplicate"]) = + Just "Duplicating a ledger tables handle" + documentFor (Namespace out ("BackendTrace" : tl)) = + documentFor (Namespace out tl :: Namespace V2.SomeBackendTrace) + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["LedgerTablesHandleCreate"] + , Namespace [] ["LedgerTablesHandleClose"] + , Namespace [] ["LedgerTablesHandleRead"] + , Namespace [] ["LedgerTablesHandleDuplicate"] + , Namespace [] ["LedgerTablesHandleCreateFirst"] + , Namespace [] ["LedgerTablesHandlePush"] + ] + ++ map (nsPrependInner "BackendTrace") (allNamespaces :: [Namespace V2.SomeBackendTrace]) + +instance LogFormatting V2.SomeBackendTrace where + forMachine dtal (V2.SomeBackendTrace ev) = unwrapV2Trace (forMachine dtal) ev + + forHuman (V2.SomeBackendTrace ev) = unwrapV2Trace forHuman ev + +instance MetaTrace V2.SomeBackendTrace where + namespaceFor (V2.SomeBackendTrace ev) = + unwrapV2Trace (nsPrependInner "LSM" . namespaceFor) ev + + severityFor (Namespace _ ("LSM" : _)) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace out ("LSM" : tl)) = documentFor @(V2.Trace LSM.LSM) (Namespace out tl) + documentFor _ = Nothing + + allNamespaces = + map (nsPrependInner "LSM") (allNamespaces :: [Namespace (V2.Trace LSM.LSM)]) + +instance LogFormatting (V2.Trace LSM.LSM) where + forMachine _dtal (LSM.LSMTreeTrace ev) = mconcat ["kind" .= String "LSMTreeTrace", "content" .= showT ev] + forMachine dtal (LSM.LSMLookup enc) = mconcat ["kind" .= String "LSMLookup", "enclosing" .= forMachine dtal enc] + forMachine dtal (LSM.LSMUpdate enc) = mconcat ["kind" .= String "LSMUpdate", "enclosing" .= forMachine dtal enc] + forMachine dtal (LSM.LSMSnap enc) = mconcat ["kind" .= String "LSMSnap", "enclosing" .= forMachine dtal enc] + forMachine dtal (LSM.LSMOpenSession enc) = mconcat ["kind" .= String "LSMOpenSession", "enclosing" .= forMachine dtal enc] + + forHuman (LSM.LSMTreeTrace ev) = showT ev + forHuman (LSM.LSMLookup enc) = "Looking up in LSM database: " <> forHuman enc + forHuman (LSM.LSMUpdate enc) = "Updating the LSM database: " <> forHuman enc + forHuman (LSM.LSMSnap enc) = "Snapshotting the LSM database: " <> forHuman enc + forHuman (LSM.LSMOpenSession enc) = "Opening the LSM session: " <> forHuman enc + +instance MetaTrace (V2.Trace LSM.LSM) where + namespaceFor LSM.LSMTreeTrace{} = Namespace [] ["LSMTrace"] + namespaceFor LSM.LSMLookup{} = Namespace [] ["LSMLookup"] + namespaceFor LSM.LSMUpdate{} = Namespace [] ["LSMUpdate"] + namespaceFor LSM.LSMSnap{} = Namespace [] ["LSMSnap"] + namespaceFor LSM.LSMOpenSession{} = Namespace [] ["LSMOpenSession"] + + severityFor (Namespace _ ["LSMTrace"]) _ = Just Debug + severityFor (Namespace _ ["LSMLookup"]) _ = Just Debug + severityFor (Namespace _ ["LSMUpdate"]) _ = Just Debug + severityFor (Namespace _ ["LSMSnap"]) _ = Just Debug + severityFor (Namespace _ ["LSMOpenSession"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["LSMTrace"]) = + Just "A trace from the LSM-trees backend" + documentFor (Namespace _ ["LSMLookup"]) = + Just "Looking up in the LSM-trees backend" + documentFor (Namespace _ ["LSMUpdate"]) = + Just "Updating the LSM-trees backend" + documentFor (Namespace _ ["LSMSnap"]) = + Just "Snapshotting the LSM-trees backend" + documentFor (Namespace _ ["LSMOpenSession"]) = + Just "Opening the LSM-trees backend session" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["LSMTrace"] + , Namespace [] ["LSMLookup"] + , Namespace [] ["LSMUpdate"] + , Namespace [] ["LSMSnap"] + , Namespace [] ["LSMOpenSession"] + ] + +unwrapV2Trace :: + forall a backend. Typeable backend => (V2.Trace LSM.LSM -> a) -> V2.Trace backend -> a +unwrapV2Trace g ev = + case cast @(V2.Trace backend) @(V2.Trace InMemory.Mem) ev of + Just (InMemory.NoTrace v) -> absurd v + Nothing -> + case cast @(V2.Trace backend) @(V2.Trace LSM.LSM) ev of + Just t -> g t + _ -> error "blah" + +-------------------------------------------------------------------------------- +-- ImmDB.TraceEvent +-------------------------------------------------------------------------------- + +instance + (ConvertRawHash blk, StandardHash blk) => + LogFormatting (ImmDB.TraceEvent blk) + where + forMachine _dtal ImmDB.NoValidLastLocation = + mconcat ["kind" .= String "NoValidLastLocation"] + forMachine _dtal (ImmDB.ValidatedLastLocation chunkNo immTip) = + mconcat + [ "kind" .= String "ValidatedLastLocation" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "immTip" .= String (renderTipHash immTip) + , "blockNo" .= String (renderTipBlockNo immTip) + ] + forMachine dtal (ImmDB.ChunkValidationEvent traceChunkValidation) = + forMachine dtal traceChunkValidation + forMachine _dtal (ImmDB.DeletingAfter immTipWithInfo) = + mconcat + [ "kind" .= String "DeletingAfter" + , "immTipHash" .= String (renderWithOrigin renderTipHash immTipWithInfo) + , "immTipBlockNo" .= String (renderWithOrigin renderTipBlockNo immTipWithInfo) + ] + forMachine _dtal ImmDB.DBAlreadyClosed = + mconcat ["kind" .= String "DBAlreadyClosed"] + forMachine _dtal ImmDB.DBClosed = + mconcat ["kind" .= String "DBClosed"] + forMachine dtal (ImmDB.TraceCacheEvent cacheEv) = + forMachine dtal cacheEv + forMachine _dtal (ImmDB.ChunkFileDoesntFit expectPrevHash actualPrevHash) = + mconcat + [ "kind" .= String "ChunkFileDoesntFit" + , "expectedPrevHash" + .= String + ( renderChainHash + ( Text.decodeLatin1 + . toRawHash (Proxy @blk) + ) + expectPrevHash + ) + , "actualPrevHash" + .= String + ( renderChainHash + ( Text.decodeLatin1 + . toRawHash (Proxy @blk) + ) + actualPrevHash + ) + ] + forMachine _dtal (ImmDB.Migrating txt) = + mconcat + [ "kind" .= String "Migrating" + , "info" .= String txt + ] + + forHuman ImmDB.NoValidLastLocation = + "No valid last location was found. Starting from Genesis." + forHuman (ImmDB.ValidatedLastLocation cn t) = + "Found a valid last location at chunk " + <> showT cn + <> " with tip " + <> renderRealPoint (ImmDB.tipToRealPoint t) + <> "." + forHuman (ImmDB.ChunkValidationEvent e) = case e of + ImmDB.StartedValidatingChunk chunkNo outOf -> + "Validating chunk no. " + <> showT chunkNo + <> " out of " + <> showT outOf + <> ". Progress: " + <> showProgressT (chunkNoToInt chunkNo) (chunkNoToInt outOf + 1) + <> "%" + ImmDB.ValidatedChunk chunkNo outOf -> + "Validated chunk no. " + <> showT chunkNo + <> " out of " + <> showT outOf + <> ". Progress: " + <> showProgressT (chunkNoToInt chunkNo + 1) (chunkNoToInt outOf + 1) + <> "%" + ImmDB.MissingChunkFile cn -> + "The chunk file with number " <> showT cn <> " is missing." + ImmDB.InvalidChunkFile cn er -> + "The chunk file with number " <> showT cn <> " is invalid: " <> showT er + ImmDB.MissingPrimaryIndex cn -> + "The primary index of the chunk file with number " <> showT cn <> " is missing." + ImmDB.MissingSecondaryIndex cn -> + "The secondary index of the chunk file with number " <> showT cn <> " is missing." + ImmDB.InvalidPrimaryIndex cn -> + "The primary index of the chunk file with number " <> showT cn <> " is invalid." + ImmDB.InvalidSecondaryIndex cn -> + "The secondary index of the chunk file with number " <> showT cn <> " is invalid." + ImmDB.RewritePrimaryIndex cn -> + "Rewriting the primary index for the chunk file with number " <> showT cn <> "." + ImmDB.RewriteSecondaryIndex cn -> + "Rewriting the secondary index for the chunk file with number " <> showT cn <> "." + forHuman (ImmDB.ChunkFileDoesntFit ch1 ch2) = + "Chunk file doesn't fit. The hash of the block " + <> showT ch2 + <> " doesn't match the previous hash of the first block in the current epoch: " + <> showT ch1 + <> "." + forHuman (ImmDB.Migrating t) = "Migrating: " <> t + forHuman (ImmDB.DeletingAfter wot) = "Deleting chunk files after " <> showT wot + forHuman ImmDB.DBAlreadyClosed{} = "Immutable DB was already closed. Double closing." + forHuman ImmDB.DBClosed{} = "Closed Immutable DB." + forHuman (ImmDB.TraceCacheEvent ev') = + "Cache event: " <> case ev' of + ImmDB.TraceCurrentChunkHit cn curr -> "Current chunk hit: " <> showT cn <> ", cache size: " <> showT curr + ImmDB.TracePastChunkHit cn curr -> "Past chunk hit: " <> showT cn <> ", cache size: " <> showT curr + ImmDB.TracePastChunkMiss cn curr -> "Past chunk miss: " <> showT cn <> ", cache size: " <> showT curr + ImmDB.TracePastChunkEvict cn curr -> "Past chunk evict: " <> showT cn <> ", cache size: " <> showT curr + ImmDB.TracePastChunksExpired cns curr -> "Past chunks expired: " <> showT cns <> ", cache size: " <> showT curr + +instance MetaTrace (ImmDB.TraceEvent blk) where + namespaceFor ImmDB.NoValidLastLocation{} = Namespace [] ["NoValidLastLocation"] + namespaceFor ImmDB.ValidatedLastLocation{} = Namespace [] ["ValidatedLastLocation"] + namespaceFor (ImmDB.ChunkValidationEvent ev) = + nsPrependInner "ChunkValidation" (namespaceFor ev) + namespaceFor ImmDB.ChunkFileDoesntFit{} = Namespace [] ["ChunkFileDoesntFit"] + namespaceFor ImmDB.Migrating{} = Namespace [] ["Migrating"] + namespaceFor ImmDB.DeletingAfter{} = Namespace [] ["DeletingAfter"] + namespaceFor ImmDB.DBAlreadyClosed{} = Namespace [] ["DBAlreadyClosed"] + namespaceFor ImmDB.DBClosed{} = Namespace [] ["DBClosed"] + namespaceFor (ImmDB.TraceCacheEvent ev) = + nsPrependInner "CacheEvent" (namespaceFor ev) + + severityFor (Namespace _ ["NoValidLastLocation"]) _ = Just Info + severityFor (Namespace _ ["ValidatedLastLocation"]) _ = Just Info + severityFor + (Namespace out ("ChunkValidation" : tl)) + (Just (ImmDB.ChunkValidationEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("ChunkValidation" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ImmDB.TraceChunkValidation blk ImmDB.ChunkNo)) Nothing + severityFor (Namespace _ ["ChunkFileDoesntFit"]) _ = Just Warning + severityFor (Namespace _ ["Migrating"]) _ = Just Debug + severityFor (Namespace _ ["DeletingAfter"]) _ = Just Debug + severityFor (Namespace _ ["DBAlreadyClosed"]) _ = Just Error + severityFor (Namespace _ ["DBClosed"]) _ = Just Info + severityFor + (Namespace out ("CacheEvent" : tl)) + (Just (ImmDB.TraceCacheEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("CacheEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace ImmDB.TraceCacheEvent) Nothing + severityFor _ _ = Nothing + + privacyFor + (Namespace out ("ChunkValidation" : tl)) + (Just (ImmDB.ChunkValidationEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("ChunkValidation" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ImmDB.TraceChunkValidation blk ImmDB.ChunkNo)) Nothing + privacyFor + (Namespace out ("CacheEvent" : tl)) + (Just (ImmDB.TraceCacheEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("CacheEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace ImmDB.TraceCacheEvent) Nothing + privacyFor _ _ = Just Public + + detailsFor + (Namespace out ("ChunkValidation" : tl)) + (Just (ImmDB.ChunkValidationEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("ChunkValidation" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ImmDB.TraceChunkValidation blk ImmDB.ChunkNo)) Nothing + detailsFor + (Namespace out ("CacheEvent" : tl)) + (Just (ImmDB.TraceCacheEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("CacheEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace ImmDB.TraceCacheEvent) Nothing + detailsFor _ _ = Just DNormal + + documentFor (Namespace _ ["NoValidLastLocation"]) = + Just + "No valid last location was found" + documentFor (Namespace _ ["ValidatedLastLocation"]) = + Just + "The last location was validatet" + documentFor (Namespace o ("ChunkValidation" : tl)) = + documentFor (Namespace o tl :: Namespace (ImmDB.TraceChunkValidation blk chunkNo)) + documentFor (Namespace _ ["ChunkFileDoesntFit"]) = + Just $ + mconcat + [ "The hash of the last block in the previous epoch doesn't match the" + , " previous hash of the first block in the current epoch" + ] + documentFor (Namespace _ ["Migrating"]) = + Just + "Performing a migration of the on-disk files." + documentFor (Namespace _ ["DeletingAfter"]) = + Just + "Delete after" + documentFor (Namespace _ ["DBAlreadyClosed"]) = + Just + "" + documentFor (Namespace _ ["DBClosed"]) = + Just + "Closing the immutable DB" + documentFor (Namespace o ("CacheEvent" : tl)) = + documentFor (Namespace o tl :: Namespace ImmDB.TraceCacheEvent) + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["NoValidLastLocation"] + , Namespace [] ["ValidatedLastLocation"] + , Namespace [] ["ChunkFileDoesntFit"] + , Namespace [] ["Migrating"] + , Namespace [] ["DeletingAfter"] + , Namespace [] ["DBAlreadyClosed"] + , Namespace [] ["DBClosed"] + ] + ++ map + (nsPrependInner "ChunkValidation") + (allNamespaces :: [Namespace (ImmDB.TraceChunkValidation blk chunkNo)]) + ++ map + (nsPrependInner "CacheEvent") + (allNamespaces :: [Namespace ImmDB.TraceCacheEvent]) + +-------------------------------------------------------------------------------- +-- ImmDB.TraceChunkValidation +-------------------------------------------------------------------------------- + +instance ConvertRawHash blk => LogFormatting (ImmDB.TraceChunkValidation blk ImmDB.ChunkNo) where + forMachine _dtal (ImmDB.RewriteSecondaryIndex chunkNo) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.RewriteSecondaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.RewritePrimaryIndex chunkNo) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.RewritePrimaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.MissingPrimaryIndex chunkNo) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.MissingPrimaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.MissingSecondaryIndex chunkNo) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.MissingSecondaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.InvalidPrimaryIndex chunkNo) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.InvalidPrimaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.InvalidSecondaryIndex chunkNo) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.InvalidSecondaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine + _dtal + ( ImmDB.InvalidChunkFile + chunkNo + (ImmDB.ChunkErrHashMismatch hashPrevBlock prevHashOfBlock) + ) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.InvalidChunkFile.ChunkErrHashMismatch" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "hashPrevBlock" .= String (Text.decodeLatin1 . toRawHash (Proxy @blk) $ hashPrevBlock) + , "prevHashOfBlock" + .= String (renderChainHash (Text.decodeLatin1 . toRawHash (Proxy @blk)) prevHashOfBlock) + ] + forMachine dtal (ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrCorrupt pt)) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.InvalidChunkFile.ChunkErrCorrupt" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "block" .= String (renderPointForDetails dtal pt) + ] + forMachine _dtal (ImmDB.ValidatedChunk chunkNo _) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.ValidatedChunk" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.MissingChunkFile chunkNo) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.MissingChunkFile" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrRead readIncErr)) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.InvalidChunkFile.ChunkErrRead" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "error" .= String (showT readIncErr) + ] + forMachine _dtal (ImmDB.StartedValidatingChunk initialChunk finalChunk) = + mconcat + [ "kind" .= String "TraceImmutableDBEvent.StartedValidatingChunk" + , "initialChunk" .= renderChunkNo initialChunk + , "finalChunk" .= renderChunkNo finalChunk + ] + +instance MetaTrace (ImmDB.TraceChunkValidation blk chunkNo) where + namespaceFor ImmDB.StartedValidatingChunk{} = Namespace [] ["StartedValidatingChunk"] + namespaceFor ImmDB.ValidatedChunk{} = Namespace [] ["ValidatedChunk"] + namespaceFor ImmDB.MissingChunkFile{} = Namespace [] ["MissingChunkFile"] + namespaceFor ImmDB.InvalidChunkFile{} = Namespace [] ["InvalidChunkFile"] + namespaceFor ImmDB.MissingPrimaryIndex{} = Namespace [] ["MissingPrimaryIndex"] + namespaceFor ImmDB.MissingSecondaryIndex{} = Namespace [] ["MissingSecondaryIndex"] + namespaceFor ImmDB.InvalidPrimaryIndex{} = Namespace [] ["InvalidPrimaryIndex"] + namespaceFor ImmDB.InvalidSecondaryIndex{} = Namespace [] ["InvalidSecondaryIndex"] + namespaceFor ImmDB.RewritePrimaryIndex{} = Namespace [] ["RewritePrimaryIndex"] + namespaceFor ImmDB.RewriteSecondaryIndex{} = Namespace [] ["RewriteSecondaryIndex"] + + severityFor (Namespace _ ["StartedValidatingChunk"]) _ = Just Info + severityFor (Namespace _ ["ValidatedChunk"]) _ = Just Info + severityFor (Namespace _ ["MissingChunkFile"]) _ = Just Warning + severityFor (Namespace _ ["InvalidChunkFile"]) _ = Just Warning + severityFor (Namespace _ ["MissingPrimaryIndex"]) _ = Just Warning + severityFor (Namespace _ ["MissingSecondaryIndex"]) _ = Just Warning + severityFor (Namespace _ ["InvalidPrimaryIndex"]) _ = Just Warning + severityFor (Namespace _ ["InvalidSecondaryIndex"]) _ = Just Warning + severityFor (Namespace _ ["RewritePrimaryIndex"]) _ = Just Warning + severityFor (Namespace _ ["RewriteSecondaryIndex"]) _ = Just Warning + severityFor _ _ = Nothing + + documentFor (Namespace _ ["StartedValidatingChunk"]) = + Just + "" + documentFor (Namespace _ ["ValidatedChunk"]) = + Just + "" + documentFor (Namespace _ ["MissingChunkFile"]) = + Just + "" + documentFor (Namespace _ ["InvalidChunkFile"]) = + Just + "" + documentFor (Namespace _ ["MissingPrimaryIndex"]) = + Just + "" + documentFor (Namespace _ ["MissingSecondaryIndex"]) = + Just + "" + documentFor (Namespace _ ["InvalidPrimaryIndex"]) = + Just + "" + documentFor (Namespace _ ["InvalidSecondaryIndex"]) = + Just + "" + documentFor (Namespace _ ["RewritePrimaryIndex"]) = + Just + "" + documentFor (Namespace _ ["RewriteSecondaryIndex"]) = + Just + "" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["StartedValidatingChunk"] + , Namespace [] ["ValidatedChunk"] + , Namespace [] ["MissingChunkFile"] + , Namespace [] ["InvalidChunkFile"] + , Namespace [] ["MissingPrimaryIndex"] + , Namespace [] ["MissingSecondaryIndex"] + , Namespace [] ["InvalidPrimaryIndex"] + , Namespace [] ["InvalidSecondaryIndex"] + , Namespace [] ["RewritePrimaryIndex"] + , Namespace [] ["RewriteSecondaryIndex"] + ] + +-------------------------------------------------------------------------------- +-- ImmDB.TraceCacheEvent +-------------------------------------------------------------------------------- + +instance LogFormatting ImmDB.TraceCacheEvent where + forMachine _dtal (ImmDB.TraceCurrentChunkHit chunkNo nbPastChunksInCache) = + mconcat + [ "kind" .= String "TraceCurrentChunkHit" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + forMachine _dtal (ImmDB.TracePastChunkHit chunkNo nbPastChunksInCache) = + mconcat + [ "kind" .= String "TracePastChunkHit" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + forMachine _dtal (ImmDB.TracePastChunkMiss chunkNo nbPastChunksInCache) = + mconcat + [ "kind" .= String "TracePastChunkMiss" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + forMachine _dtal (ImmDB.TracePastChunkEvict chunkNo nbPastChunksInCache) = + mconcat + [ "kind" .= String "TracePastChunkEvict" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + forMachine _dtal (ImmDB.TracePastChunksExpired chunkNos nbPastChunksInCache) = + mconcat + [ "kind" .= String "TracePastChunksExpired" + , "chunkNos" .= String (Text.pack . show $ map renderChunkNo chunkNos) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + +instance MetaTrace ImmDB.TraceCacheEvent where + namespaceFor ImmDB.TraceCurrentChunkHit{} = Namespace [] ["CurrentChunkHit"] + namespaceFor ImmDB.TracePastChunkHit{} = Namespace [] ["PastChunkHit"] + namespaceFor ImmDB.TracePastChunkMiss{} = Namespace [] ["PastChunkMiss"] + namespaceFor ImmDB.TracePastChunkEvict{} = Namespace [] ["PastChunkEvict"] + namespaceFor ImmDB.TracePastChunksExpired{} = Namespace [] ["PastChunkExpired"] + + severityFor (Namespace _ ["CurrentChunkHit"]) _ = Just Debug + severityFor (Namespace _ ["PastChunkHit"]) _ = Just Debug + severityFor (Namespace _ ["PastChunkMiss"]) _ = Just Debug + severityFor (Namespace _ ["PastChunkEvict"]) _ = Just Debug + severityFor (Namespace _ ["PastChunkExpired"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["CurrentChunkHit"]) = + Just + "Current chunk found in the cache." + documentFor (Namespace _ ["PastChunkHit"]) = + Just + "Past chunk found in the cache" + documentFor (Namespace _ ["PastChunkMiss"]) = + Just + "Past chunk was not found in the cache" + documentFor (Namespace _ ["PastChunkEvict"]) = + Just $ + mconcat + [ "The least recently used past chunk was evicted because the cache" + , " was full." + ] + documentFor (Namespace _ ["PastChunkExpired"]) = + Just + "" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["CurrentChunkHit"] + , Namespace [] ["PastChunkHit"] + , Namespace [] ["PastChunkMiss"] + , Namespace [] ["PastChunkEvict"] + , Namespace [] ["PastChunkExpired"] + ] + +-------------------------------------------------------------------------------- +-- VolDb.TraceEvent +-------------------------------------------------------------------------------- + +instance StandardHash blk => LogFormatting (VolDB.TraceEvent blk) where + forMachine _dtal VolDB.DBAlreadyClosed = + mconcat ["kind" .= String "DBAlreadyClosed"] + forMachine _dtal (VolDB.BlockAlreadyHere blockId) = + mconcat + [ "kind" .= String "BlockAlreadyHere" + , "blockId" .= String (showT blockId) + ] + forMachine _dtal (VolDB.Truncate pErr fsPath blockOffset) = + mconcat + [ "kind" .= String "Truncate" + , "parserError" .= String (showT pErr) + , "file" .= String (showT fsPath) + , "blockOffset" .= String (showT blockOffset) + ] + forMachine _dtal (VolDB.InvalidFileNames fsPaths) = + mconcat + [ "kind" .= String "InvalidFileNames" + , "files" .= String (Text.pack . show $ map show fsPaths) + ] + forMachine _dtal VolDB.DBClosed = + mconcat ["kind" .= String "DBClosed"] + +instance MetaTrace (VolDB.TraceEvent blk) where + namespaceFor VolDB.DBAlreadyClosed{} = Namespace [] ["DBAlreadyClosed"] + namespaceFor VolDB.BlockAlreadyHere{} = Namespace [] ["BlockAlreadyHere"] + namespaceFor VolDB.Truncate{} = Namespace [] ["Truncate"] + namespaceFor VolDB.InvalidFileNames{} = Namespace [] ["InvalidFileNames"] + namespaceFor VolDB.DBClosed{} = Namespace [] ["DBClosed"] + + severityFor (Namespace _ ["DBAlreadyClosed"]) _ = Just Debug + severityFor (Namespace _ ["BlockAlreadyHere"]) _ = Just Debug + severityFor (Namespace _ ["Truncate"]) _ = Just Debug + severityFor (Namespace _ ["InvalidFileNames"]) _ = Just Debug + severityFor (Namespace _ ["DBClosed"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["DBAlreadyClosed"]) = + Just + "When closing the DB it was found it is closed already." + documentFor (Namespace _ ["BlockAlreadyHere"]) = + Just + "A block was found to be already in the DB." + documentFor (Namespace _ ["Truncate"]) = + Just + "Truncates a file up to offset because of the error." + documentFor (Namespace _ ["InvalidFileNames"]) = + Just + "Reports a list of invalid file paths." + documentFor (Namespace _ ["DBClosed"]) = + Just + "Closing the volatile DB" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["DBAlreadyClosed"] + , Namespace [] ["BlockAlreadyHere"] + , Namespace [] ["Truncate"] + , Namespace [] ["InvalidFileNames"] + , Namespace [] ["DBClosed"] + ] + +-------------------------------------------------------------------------------- +-- ChainInformation +-------------------------------------------------------------------------------- + +sevLedgerEvent :: LedgerEvent blk -> SeverityS +sevLedgerEvent (LedgerUpdate _) = Notice +sevLedgerEvent (LedgerWarning _) = Critical + +showProgressT :: Int -> Int -> Text +showProgressT chunkNo outOf = + Text.pack + ( showFFloat + (Just 2) + (100 * fromIntegral chunkNo / fromIntegral outOf :: Float) + mempty + ) + +data ChainInformation = ChainInformation + { slots :: Word64 + , blocks :: Word64 + , density :: Rational + -- ^ the actual number of blocks created over the maximum expected number + -- of blocks that could be created over the span of the last @k@ blocks. + , epoch :: EpochNo + -- ^ In which epoch is the tip of the current chain + , slotInEpoch :: Word64 + -- ^ Relative slot number of the tip of the current chain within the + -- epoch. + , blocksUncoupledDelta :: Int64 + , tipBlockHash :: Text + -- ^ Hash of the last adopted block. + , tipBlockParentHash :: Text + -- ^ Hash of the parent block of the last adopted block. + , tipBlockIssuerVerificationKeyHash :: BlockIssuerVerificationKeyHash + -- ^ Hash of the last adopted block issuer's verification key. + } + +chainInformation :: + forall blk. + HasHeader (Header blk) => + HasIssuer blk => + ConvertRawHash blk => + ChainDB.SelectionChangedInfo blk -> + AF.AnchoredFragment (Header blk) -> + -- | New fragment. + AF.AnchoredFragment (Header blk) -> + Int64 -> + ChainInformation +chainInformation selChangedInfo oldFrag frag blocksUncoupledDelta = + ChainInformation + { slots = unSlotNo $ fromWithOrigin 0 (AF.headSlot frag) + , blocks = unBlockNo $ fromWithOrigin (BlockNo 1) (AF.headBlockNo frag) + , density = fragmentChainDensity frag + , epoch = ChainDB.newTipEpoch selChangedInfo + , slotInEpoch = ChainDB.newTipSlotInEpoch selChangedInfo + , blocksUncoupledDelta = blocksUncoupledDelta + , tipBlockHash = renderHeaderHash (Proxy @blk) $ realPointHash (ChainDB.newTipPoint selChangedInfo) + , tipBlockParentHash = + renderChainHash (Text.decodeLatin1 . B16.encode . toRawHash (Proxy @blk)) $ AF.headHash oldFrag + , tipBlockIssuerVerificationKeyHash = tipIssuerVkHash + } + where + tipIssuerVkHash :: BlockIssuerVerificationKeyHash + tipIssuerVkHash = either (const NoBlockIssuer) getIssuerVerificationKeyHash (AF.head frag) + +fragmentChainDensity :: + HasHeader (Header blk) => + AF.AnchoredFragment (Header blk) -> Rational +fragmentChainDensity frag = calcDensity blockD slotD + where + calcDensity :: Word64 -> Word64 -> Rational + calcDensity bl sl + | sl > 0 = toRational bl / toRational sl + | otherwise = 0 + slotN = unSlotNo $ fromWithOrigin 0 (AF.headSlot frag) + -- Slot of the tip - slot @k@ blocks back. Use 0 as the slot for genesis + -- includes EBBs + slotD = + slotN + - unSlotNo (fromWithOrigin 0 (AF.lastSlot frag)) + -- Block numbers start at 1. We ignore the genesis EBB, which has block number 0. + blockD = blockN - firstBlock + blockN = unBlockNo $ fromWithOrigin (BlockNo 1) (AF.headBlockNo frag) + firstBlock = case unBlockNo . blockNo <$> AF.last frag of + -- Empty fragment, no blocks. We have that @blocks = 1 - 1 = 0@ + Left _ -> 1 + -- The oldest block is the genesis EBB with block number 0, + -- don't let it contribute to the number of blocks + Right 0 -> 1 + Right b -> b + +-------------------------------------------------------------------------------- +-- Other orophans +-------------------------------------------------------------------------------- + +instance LogFormatting LedgerDB.DiskSnapshot where + forMachine DDetailed snap = + mconcat + [ "kind" .= String "snapshot" + , "snapshot" .= String (Text.pack $ show snap) + ] + forMachine _ _snap = mconcat ["kind" .= String "snapshot"] + +instance + ( StandardHash blk + , LogFormatting (ValidationErr (BlockProtocol blk)) + , LogFormatting (OtherHeaderEnvelopeError blk) + ) => + LogFormatting (HeaderError blk) + where + forMachine dtal (HeaderProtocolError err) = + mconcat + [ "kind" .= String "HeaderProtocolError" + , "error" .= forMachine dtal err + ] + forMachine dtal (HeaderEnvelopeError err) = + mconcat + [ "kind" .= String "HeaderEnvelopeError" + , "error" .= forMachine dtal err + ] + +instance + ( StandardHash blk + , LogFormatting (OtherHeaderEnvelopeError blk) + ) => + LogFormatting (HeaderEnvelopeError blk) + where + forMachine _dtal (UnexpectedBlockNo expect act) = + mconcat + [ "kind" .= String "UnexpectedBlockNo" + , "expected" .= condense expect + , "actual" .= condense act + ] + forMachine _dtal (UnexpectedSlotNo expect act) = + mconcat + [ "kind" .= String "UnexpectedSlotNo" + , "expected" .= condense expect + , "actual" .= condense act + ] + forMachine _dtal (UnexpectedPrevHash expect act) = + mconcat + [ "kind" .= String "UnexpectedPrevHash" + , "expected" .= String (Text.pack $ show expect) + , "actual" .= String (Text.pack $ show act) + ] + forMachine _dtal (CheckpointMismatch blockNumber hdrHashExpected hdrHashActual) = + mconcat + [ "kind" .= String "CheckpointMismatch" + , "blockNo" .= String (Text.pack $ show blockNumber) + , "expected" .= String (Text.pack $ show hdrHashExpected) + , "actual" .= String (Text.pack $ show hdrHashActual) + ] + forMachine dtal (OtherHeaderEnvelopeError err) = + forMachine dtal err + +instance + ( LogFormatting (LedgerError blk) + , LogFormatting (HeaderError blk) + , Show (PerasError blk) + ) => + LogFormatting (ExtValidationError blk) + where + -- The two Peras arms carry types with no 'LogFormatting' instance to defer + -- to: 'PerasError' is a type family, so all we can rely on is its 'Show'. + forMachine dtal (ExtValidationErrorLedger err) = forMachine dtal err + forMachine dtal (ExtValidationErrorHeader err) = forMachine dtal err + forMachine _dtal (ExtValidationErrorPerasEpochContextResolver err) = + mconcat + [ "kind" .= String "ExtValidationErrorPerasEpochContextResolver" + , "error" .= String (showT err) + ] + forMachine _dtal (ExtValidationErrorPerasCertInBlock err) = + mconcat + [ "kind" .= String "ExtValidationErrorPerasCertInBlock" + , "error" .= String (showT err) + ] + + forHuman (ExtValidationErrorLedger err) = forHuman err + forHuman (ExtValidationErrorHeader err) = forHuman err + forHuman (ExtValidationErrorPerasEpochContextResolver err) = + "Could not resolve the Peras epoch context: " <> showT err + forHuman (ExtValidationErrorPerasCertInBlock err) = + "Invalid Peras certificate in block: " <> showT err + + asMetrics (ExtValidationErrorLedger err) = asMetrics err + asMetrics (ExtValidationErrorHeader err) = asMetrics err + asMetrics ExtValidationErrorPerasEpochContextResolver{} = [] + asMetrics ExtValidationErrorPerasCertInBlock{} = [] + +instance + Show (PBFT.PBftVerKeyHash c) => + LogFormatting (PBFT.PBftValidationErr c) + where + forMachine _dtal (PBFT.PBftInvalidSignature text) = + mconcat + [ "kind" .= String "PBftInvalidSignature" + , "error" .= String text + ] + forMachine _dtal (PBFT.PBftNotGenesisDelegate vkhash _ledgerView) = + mconcat + [ "kind" .= String "PBftNotGenesisDelegate" + , "vk" .= String (Text.pack $ show vkhash) + ] + forMachine _dtal (PBFT.PBftExceededSignThreshold vkhash numForged) = + mconcat + [ "kind" .= String "PBftExceededSignThreshold" + , "vk" .= String (Text.pack $ show vkhash) + , "numForged" .= String (Text.pack (show numForged)) + ] + forMachine _dtal PBFT.PBftInvalidSlot = + mconcat + [ "kind" .= String "PBftInvalidSlot" + ] + +instance + Show (PBFT.PBftVerKeyHash c) => + LogFormatting (PBFT.PBftCannotForge c) + where + forMachine _dtal (PBFT.PBftCannotForgeInvalidDelegation vkhash) = + mconcat + [ "kind" .= String "PBftCannotForgeInvalidDelegation" + , "vk" .= String (Text.pack $ show vkhash) + ] + forMachine _dtal (PBFT.PBftCannotForgeThresholdExceeded numForged) = + mconcat + [ "kind" .= String "PBftCannotForgeThresholdExceeded" + , "numForged" .= numForged + ] + +-- ChainDB.TraceAddPerasCertEvent instances +instance ConvertRawHash blk => LogFormatting (ChainDB.TraceAddPerasCertEvent blk) where + forHuman (ChainDB.AddedPerasCertToQueue roundNo boostedBlock _queueSize) = + "Added Peras certificate for round " + <> Text.pack (show roundNo) + <> " boosting block " + <> renderPoint boostedBlock + <> " to queue" + forHuman (ChainDB.PoppedPerasCertFromQueue roundNo boostedBlock) = + "Popped Peras certificate for round " + <> Text.pack (show roundNo) + <> " boosting block " + <> renderPoint boostedBlock + <> " from queue" + forHuman (ChainDB.IgnorePerasCertTooOld roundNo boostedBlock immutableSlot) = + "Ignored Peras certificate for round " + <> Text.pack (show roundNo) + <> " boosting block " + <> renderPoint boostedBlock + <> " (too old, immutable slot: " + <> renderPoint (AF.anchorToPoint immutableSlot) + <> ")" + forHuman (ChainDB.PerasCertBoostsCurrentChain roundNo boostedBlock) = + "Peras certificate for round " + <> Text.pack (show roundNo) + <> " boosts current chain block " + <> renderPoint boostedBlock + forHuman (ChainDB.PerasCertBoostsGenesis roundNo) = + "Peras certificate for round " <> Text.pack (show roundNo) <> " boosts Genesis" + forHuman (ChainDB.PerasCertBoostsBlockNotYetReceived roundNo boostedBlock) = + "Peras certificate for round " + <> Text.pack (show roundNo) + <> " boosts block " + <> renderPoint boostedBlock + <> " not yet received" + forHuman (ChainDB.ChainSelectionForBoostedBlock roundNo boostedBlock) = + "Chain selection for block " + <> renderPoint boostedBlock + <> " boosted by Peras certificate from round " + <> Text.pack (show roundNo) + + forMachine _dtal (ChainDB.AddedPerasCertToQueue roundNo boostedBlock queueSize) = + mconcat + [ "kind" .= String "AddedPerasCertToQueue" + , "round" .= String (Text.pack $ show roundNo) + , "boostedBlock" .= String (renderPoint boostedBlock) + , "queueSize" .= enclosingValue queueSize + ] + forMachine _dtal (ChainDB.PoppedPerasCertFromQueue roundNo boostedBlock) = + mconcat + [ "kind" .= String "PoppedPerasCertFromQueue" + , "round" .= String (Text.pack $ show roundNo) + , "boostedBlock" .= String (renderPoint boostedBlock) + ] + forMachine _dtal (ChainDB.IgnorePerasCertTooOld roundNo boostedBlock immutableSlot) = + mconcat + [ "kind" .= String "IgnorePerasCertTooOld" + , "round" .= String (Text.pack $ show roundNo) + , "boostedBlock" .= String (renderPoint boostedBlock) + , "immutableSlot" .= String (renderPoint (AF.anchorToPoint immutableSlot)) + ] + forMachine _dtal (ChainDB.PerasCertBoostsCurrentChain roundNo boostedBlock) = + mconcat + [ "kind" .= String "PerasCertBoostsCurrentChain" + , "round" .= String (Text.pack $ show roundNo) + , "boostedBlock" .= String (renderPoint boostedBlock) + ] + forMachine _dtal (ChainDB.PerasCertBoostsGenesis roundNo) = + mconcat + [ "kind" .= String "PerasCertBoostsGenesis" + , "round" .= String (Text.pack $ show roundNo) + ] + forMachine _dtal (ChainDB.PerasCertBoostsBlockNotYetReceived roundNo boostedBlock) = + mconcat + [ "kind" .= String "PerasCertBoostsBlockNotYetReceived" + , "round" .= String (Text.pack $ show roundNo) + , "boostedBlock" .= String (renderPoint boostedBlock) + ] + forMachine _dtal (ChainDB.ChainSelectionForBoostedBlock roundNo boostedBlock) = + mconcat + [ "kind" .= String "ChainSelectionForBoostedBlock" + , "round" .= String (Text.pack $ show roundNo) + , "boostedBlock" .= String (renderPoint boostedBlock) + ] + + asMetrics _ = [] + +-- ChainDB.TraceAddPerasCertEvent MetaTrace instance +instance MetaTrace (ChainDB.TraceAddPerasCertEvent blk) where + namespaceFor ChainDB.AddedPerasCertToQueue{} = Namespace [] ["AddedPerasCertToQueue"] + namespaceFor (ChainDB.PoppedPerasCertFromQueue _ _) = Namespace [] ["PoppedPerasCertFromQueue"] + namespaceFor ChainDB.IgnorePerasCertTooOld{} = Namespace [] ["IgnorePerasCertTooOld"] + namespaceFor (ChainDB.PerasCertBoostsCurrentChain _ _) = Namespace [] ["PerasCertBoostsCurrentChain"] + namespaceFor (ChainDB.PerasCertBoostsGenesis _) = Namespace [] ["PerasCertBoostsGenesis"] + namespaceFor (ChainDB.PerasCertBoostsBlockNotYetReceived _ _) = Namespace [] ["PerasCertBoostsBlockNotYetReceived"] + namespaceFor (ChainDB.ChainSelectionForBoostedBlock _ _) = Namespace [] ["ChainSelectionForBoostedBlock"] + + severityFor (Namespace _ ["AddedPerasCertToQueue"]) _ = Just Debug + severityFor (Namespace _ ["PoppedPerasCertFromQueue"]) _ = Just Debug + severityFor (Namespace _ ["IgnorePerasCertTooOld"]) _ = Just Info + severityFor (Namespace _ ["PerasCertBoostsCurrentChain"]) _ = Just Info + severityFor (Namespace _ ["PerasCertBoostsGenesis"]) _ = Just Info + severityFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) _ = Just Info + severityFor (Namespace _ ["ChainSelectionForBoostedBlock"]) _ = Just Info + severityFor _ _ = Nothing + + privacyFor (Namespace _ ["AddedPerasCertToQueue"]) _ = Just Public + privacyFor (Namespace _ ["PoppedPerasCertFromQueue"]) _ = Just Public + privacyFor (Namespace _ ["IgnorePerasCertTooOld"]) _ = Just Public + privacyFor (Namespace _ ["PerasCertBoostsCurrentChain"]) _ = Just Public + privacyFor (Namespace _ ["PerasCertBoostsGenesis"]) _ = Just Public + privacyFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) _ = Just Public + privacyFor (Namespace _ ["ChainSelectionForBoostedBlock"]) _ = Just Public + privacyFor _ _ = Nothing + + detailsFor (Namespace _ ["AddedPerasCertToQueue"]) _ = Just DDetailed + detailsFor (Namespace _ ["PoppedPerasCertFromQueue"]) _ = Just DDetailed + detailsFor (Namespace _ ["IgnorePerasCertTooOld"]) _ = Just DNormal + detailsFor (Namespace _ ["PerasCertBoostsCurrentChain"]) _ = Just DNormal + detailsFor (Namespace _ ["PerasCertBoostsGenesis"]) _ = Just DNormal + detailsFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) _ = Just DNormal + detailsFor (Namespace _ ["ChainSelectionForBoostedBlock"]) _ = Just DNormal + detailsFor _ _ = Nothing + + documentFor (Namespace _ ["AddedPerasCertToQueue"]) = Just "Peras certificate added to processing queue" + documentFor (Namespace _ ["PoppedPerasCertFromQueue"]) = Just "Peras certificate popped from processing queue" + documentFor (Namespace _ ["IgnorePerasCertTooOld"]) = Just "Peras certificate ignored as it is too old compared to immutable slot" + documentFor (Namespace _ ["PerasCertBoostsCurrentChain"]) = Just "Peras certificate boosts a block on the current selection" + documentFor (Namespace _ ["PerasCertBoostsGenesis"]) = Just "Peras certificate boosts the Genesis point" + documentFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) = Just "Peras certificate boosts a block not yet received" + documentFor (Namespace _ ["ChainSelectionForBoostedBlock"]) = Just "Perform chain selection for block boosted by Peras certificate" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["AddedPerasCertToQueue"] + , Namespace [] ["PoppedPerasCertFromQueue"] + , Namespace [] ["IgnorePerasCertTooOld"] + , Namespace [] ["PerasCertBoostsCurrentChain"] + , Namespace [] ["PerasCertBoostsGenesis"] + , Namespace [] ["PerasCertBoostsBlockNotYetReceived"] + , Namespace [] ["ChainSelectionForBoostedBlock"] + ] diff --git a/tracing/Ouroboros/Consensus/Tracing/Consensus.hs b/tracing/Ouroboros/Consensus/Tracing/Consensus.hs new file mode 100644 index 0000000000..360eeee413 --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/Consensus.hs @@ -0,0 +1,3000 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ouroboros.Consensus.Tracing.Consensus + ( initialClientMetrics + , calculateBlockFetchClientMetrics + , servedBlockLatest + , ClientMetrics + , txsMempoolTimeoutSoftCounterName + , txsSyncDurationTotalCounterName + , impliesMempoolTimeoutSoft + ) where + +import qualified Cardano.KESAgent.Processes.ServiceClient as Agent +import Cardano.Logging +import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) +import Cardano.Slotting.Slot (WithOrigin (..)) +import Control.Exception (displayException) +import Control.Monad (guard) +import Data.Aeson (ToJSON, Value (..), object, toJSON, (.=)) +import qualified Data.Aeson as Aeson +import Data.Foldable (Foldable (toList)) +import Data.Int (Int64) +import Data.IntPSQ (IntPSQ) +import qualified Data.IntPSQ as Pq +import qualified Data.Text as Text +import Data.Time (NominalDiffTime) +import Data.Word (Word32, Word64) +import Network.TypedProtocol.Core +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime (SystemStart (..)) +import Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockchainTimeEvent (..)) +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Genesis.Governor + ( DensityBounds (..) + , GDDDebugInfo (..) + , TraceGDDEvent (..) + ) +import Ouroboros.Consensus.Ledger.Extended (ExtValidationError) +import Ouroboros.Consensus.Ledger.Inspect (LedgerEvent (..), LedgerUpdate, LedgerWarning) +import Ouroboros.Consensus.Ledger.SupportsMempool + ( ApplyTxErr + , ByteSize32 (..) + , GenTxId + , HasTxId + , LedgerSupportsMempool + , TxMeasurePhase1Metrics (..) + , TxMeasurePhase2Metrics (..) + , txForgetValidated + , txId + ) +import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Mempool + ( MempoolRejectionDetails (..) + , MempoolSize (..) + , TraceEventMempool (..) + , jsonMempoolRejectionDetails + ) +import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server + ( TraceBlockFetchServerEvent (..) + ) +import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as ChainSync +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Jumping +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State (JumpInfo (..)) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Server +import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server + ( TraceLocalTxSubmissionServerEvent (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound + ( NumObjectsProcessed (..) + , TraceObjectDiffusionInbound (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound + ( TraceObjectDiffusionOutbound (..) + ) +import Ouroboros.Consensus.Node.GSM +import Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints, estimateBlockSize) +import Ouroboros.Consensus.Node.Tracers +import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey +import Ouroboros.Consensus.Protocol.Praos.AgentClient +import Ouroboros.Consensus.Tracing.ConsensusStartupException () +import Ouroboros.Consensus.Tracing.ConvertTxId (ConvertTxId (..)) +import Ouroboros.Consensus.Tracing.Formatting () +import Ouroboros.Consensus.Tracing.KESInfo (HasKESInfo (..)) +import Ouroboros.Consensus.Tracing.Render +import Ouroboros.Consensus.Util.Enclose +import qualified Ouroboros.Network.AnchoredFragment as AF +import qualified Ouroboros.Network.AnchoredSeq as AS +import Ouroboros.Network.Block hiding (blockPrevHash) +import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..)) +import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch +import Ouroboros.Network.BlockFetch.Decision +import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..)) +import Ouroboros.Network.OrphanInstances () +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) + +enclosingValue :: ToJSON a => Enclosing' a -> Value +enclosingValue RisingEdge = object ["edge" .= String "Starting"] +enclosingValue (FallingEdgeWith a) = object ["edge" .= toJSON a] + +-------------------------------------------------------------------------------- +-- TraceLabelCreds peer a +-------------------------------------------------------------------------------- + +instance LogFormatting a => LogFormatting (TraceLabelCreds a) where + forMachine dtal (TraceLabelCreds creds a) = + mconcat $ ("credentials" .= toJSON creds) : [forMachine dtal a] + + forHuman (TraceLabelCreds creds a) = + "With label " <> (Text.pack . show) creds <> ", " <> forHuman a + asMetrics (TraceLabelCreds _creds a) = + asMetrics a + +instance MetaTrace a => MetaTrace (TraceLabelCreds a) where + namespaceFor (TraceLabelCreds _label obj) = (nsCast . namespaceFor) obj + severityFor ns Nothing = severityFor (nsCast ns :: Namespace a) Nothing + severityFor ns (Just (TraceLabelCreds _label obj)) = + severityFor (nsCast ns :: Namespace a) (Just obj) + privacyFor ns Nothing = privacyFor (nsCast ns :: Namespace a) Nothing + privacyFor ns (Just (TraceLabelCreds _label obj)) = + privacyFor (nsCast ns :: Namespace a) (Just obj) + detailsFor ns Nothing = detailsFor (nsCast ns :: Namespace a) Nothing + detailsFor ns (Just (TraceLabelCreds _label obj)) = + detailsFor (nsCast ns :: Namespace a) (Just obj) + documentFor ns = documentFor (nsCast ns :: Namespace a) + metricsDocFor ns = metricsDocFor (nsCast ns :: Namespace a) + allNamespaces = map nsCast (allNamespaces :: [Namespace a]) + +-------------------------------------------------------------------------------- +-- TraceLabelPeer peer a +-------------------------------------------------------------------------------- + +instance + (LogFormatting peer, Show peer, LogFormatting a) => + LogFormatting (TraceLabelPeer peer a) + where + forMachine dtal (TraceLabelPeer peerid a) = + mconcat ["peer" .= forMachine dtal peerid] <> forMachine dtal a + forHuman (TraceLabelPeer peerid a) = + "Peer is: (" + <> showT peerid + <> "). " + <> forHuman a + asMetrics (TraceLabelPeer _peerid a) = asMetrics a + +instance MetaTrace a => MetaTrace (TraceLabelPeer label a) where + namespaceFor (TraceLabelPeer _label obj) = (nsCast . namespaceFor) obj + severityFor ns Nothing = severityFor (nsCast ns :: Namespace a) Nothing + severityFor ns (Just (TraceLabelPeer _label obj)) = + severityFor (nsCast ns) (Just obj) + privacyFor ns Nothing = privacyFor (nsCast ns :: Namespace a) Nothing + privacyFor ns (Just (TraceLabelPeer _label obj)) = + privacyFor (nsCast ns) (Just obj) + detailsFor ns Nothing = detailsFor (nsCast ns :: Namespace a) Nothing + detailsFor ns (Just (TraceLabelPeer _label obj)) = + detailsFor (nsCast ns) (Just obj) + documentFor ns = documentFor (nsCast ns :: Namespace a) + metricsDocFor ns = metricsDocFor (nsCast ns :: Namespace a) + allNamespaces = map nsCast (allNamespaces :: [Namespace a]) + +instance + (LogFormatting (LedgerUpdate blk), LogFormatting (LedgerWarning blk)) => + LogFormatting (LedgerEvent blk) + where + forMachine dtal = \case + LedgerUpdate update -> forMachine dtal update + LedgerWarning warning -> forMachine dtal warning + +-------------------------------------------------------------------------------- +-- ChainSyncClient Tracer +-------------------------------------------------------------------------------- + +instance + (ConvertRawHash blk, ConvertRawHash (Header blk), LedgerSupportsProtocol blk) => + LogFormatting (ChainSync.TraceChainSyncClientEvent blk) + where + forHuman = \case + ChainSync.TraceDownloadedHeader pt -> + mconcat + [ "While following a candidate chain, we rolled forward by downloading a" + , " header. " + , showT (headerPoint pt) + ] + ChainSync.TraceRolledBack tip -> + "While following a candidate chain, we rolled back to the given point: " <> showT tip + ChainSync.TraceException exc -> + "An exception was thrown by the Chain Sync Client. " <> showT exc + ChainSync.TraceFoundIntersection{} -> + mconcat + [ "We found an intersection between our chain fragment and the" + , " candidate's chain." + ] + ChainSync.TraceTermination res -> + "The client has terminated. " <> showT res + ChainSync.TraceValidatedHeader header -> + "The header has been validated" <> showT (headerHash header) + ChainSync.TraceWaitingBeyondForecastHorizon slotNo -> + mconcat + [ "The slot number " <> showT slotNo <> " is beyond the forecast horizon, the ChainSync client" + , " cannot yet validate a header in this slot and therefore is waiting" + ] + ChainSync.TraceAccessingForecastHorizon slotNo -> + mconcat + [ "The slot number " <> showT slotNo <> ", which was previously beyond the forecast horizon, has now" + , " entered it, and we can resume processing." + ] + ChainSync.TraceGaveLoPToken{} -> + mconcat + [ "Whether we added a token to the LoP bucket of the peer. Also carries" + , "the considered header and the best block number known prior to this" + , "header" + ] + ChainSync.TraceOfferJump point -> + mconcat + [ "ChainSync Jumping -- we are offering a jump to the server, to point: " + , showT point + ] + ChainSync.TraceJumpResult (AcceptedJump instruction) -> + mconcat + [ "ChainSync Jumping -- the client accepted the jump to " + , showT (jumpInstructionToPoint instruction) + ] + ChainSync.TraceJumpResult (RejectedJump instruction) -> + mconcat + [ "ChainSync Jumping -- the client rejected the jump to " + , showT (jumpInstructionToPoint instruction) + ] + ChainSync.TraceJumpingWaitingForNextInstruction -> + "ChainSync Jumping -- the client is blocked, waiting for its next instruction." + ChainSync.TraceJumpingInstructionIs RunNormally -> + "ChainSyncJumping -- the client is asked to run normally" + ChainSync.TraceJumpingInstructionIs Restart -> + mconcat + [ "ChainSyncJumping -- the client is asked to restart. This is necessary" + , "when disengaging a peer of which we know no point that we could set" + , "the intersection of the ChainSync server to." + ] + ChainSync.TraceJumpingInstructionIs (JumpInstruction instruction) -> + mconcat + [ "ChainSync Jumping -- the client is asked to jump to " + , showT (jumpInstructionToPoint instruction) + ] + ChainSync.TraceDrainingThePipe n -> + "ChainSync client is draining the pipe. Pipelined messages expected: " <> showT (natToInt n) + where + jumpInstructionToPoint = + AF.headPoint . jTheirFragment . \case + JumpTo ji -> ji + JumpToGoodPoint ji -> ji + + forMachine dtal = \case + ChainSync.TraceDownloadedHeader h -> + mconcat + [ "kind" .= String "DownloadedHeader" + , tipToObject (tipFromHeader h) + ] + ChainSync.TraceRolledBack tip -> + mconcat + [ "kind" .= String "RolledBack" + , "tip" .= forMachine dtal tip + ] + ChainSync.TraceException exc -> + mconcat + [ "kind" .= String "Exception" + , "exception" .= String (Text.pack $ show exc) + ] + ChainSync.TraceFoundIntersection{} -> + mconcat + [ "kind" .= String "FoundIntersection" + ] + ChainSync.TraceTermination reason -> + mconcat + [ "kind" .= String "Termination" + , "reason" .= String (Text.pack $ show reason) + ] + ChainSync.TraceValidatedHeader header -> + mconcat + [ "kind" .= String "ValidatedHeader" + , "headerHash" .= showT (headerHash header) + ] + ChainSync.TraceWaitingBeyondForecastHorizon slotNo -> + mconcat + [ "kind" .= String "WaitingBeyondForecastHorizon" + , "slotNo" .= slotNo + ] + ChainSync.TraceAccessingForecastHorizon slotNo -> + mconcat + [ "kind" .= String "AccessingForecastHorizon" + , "slotNo" .= slotNo + ] + ChainSync.TraceGaveLoPToken tokenAdded header aBlockNo -> + mconcat + [ "kind" .= String "TraceGaveLoPToken" + , "tokenAdded" .= tokenAdded + , "headerHash" .= showT (headerHash header) + , "blockNo" .= aBlockNo + ] + ChainSync.TraceOfferJump point -> + mconcat + [ "kind" .= String "TraceOfferJump" + , "point" .= showT point + ] + ChainSync.TraceJumpResult jumpResult -> + mconcat + [ "kind" .= String "TraceJumpResult" + , "result" .= case jumpResult of + AcceptedJump _ -> String "AcceptedJump" + RejectedJump _ -> String "RejectedJump" + ] + ChainSync.TraceJumpingWaitingForNextInstruction -> + mconcat + [ "kind" .= String "TraceJumpingWaitingForNextInstruction" + ] + ChainSync.TraceJumpingInstructionIs instruction -> + mconcat + [ "kind" .= String "TraceJumpingInstructionIs" + , "instr" .= instructionToObject instruction + ] + ChainSync.TraceDrainingThePipe n -> + mconcat + [ "kind" .= String "TraceDrainingThePipe" + , "n" .= natToInt n + ] + where + instructionToObject :: Instruction blk -> Aeson.Object + instructionToObject = \case + RunNormally -> + mconcat ["kind" .= String "RunNormally"] + Restart -> + mconcat ["kind" .= String "Restart"] + JumpInstruction info -> + mconcat + [ "kind" .= String "JumpInstruction" + , "payload" .= jumpInstructionToObject info + ] + + jumpInstructionToObject :: JumpInstruction blk -> Aeson.Object + jumpInstructionToObject = \case + JumpTo info -> + mconcat + [ "kind" .= String "JumpTo" + , "point" .= showT (jumpInfoToPoint info) + ] + JumpToGoodPoint info -> + mconcat + [ "kind" .= String "JumpToGoodPoint" + , "point" .= showT (jumpInfoToPoint info) + ] + + jumpInfoToPoint = AF.headPoint . jTheirFragment + +tipToObject :: forall blk. ConvertRawHash blk => Tip blk -> Aeson.Object +tipToObject = \case + TipGenesis -> + mconcat + [ "slot" .= toJSON (0 :: Int) + , "block" .= String "genesis" + , "blockNo" .= toJSON ((-1) :: Int) + ] + Tip slot hash blockno -> + mconcat + [ "slot" .= slot + , "block" .= String (renderHeaderHash (Proxy @blk) hash) + , "blockNo" .= blockno + ] + +instance MetaTrace (ChainSync.TraceChainSyncClientEvent blk) where + namespaceFor = \case + ChainSync.TraceDownloadedHeader{} -> + Namespace [] ["DownloadedHeader"] + ChainSync.TraceRolledBack{} -> + Namespace [] ["RolledBack"] + ChainSync.TraceException{} -> + Namespace [] ["Exception"] + ChainSync.TraceFoundIntersection{} -> + Namespace [] ["FoundIntersection"] + ChainSync.TraceTermination{} -> + Namespace [] ["Termination"] + ChainSync.TraceValidatedHeader{} -> + Namespace [] ["ValidatedHeader"] + ChainSync.TraceWaitingBeyondForecastHorizon{} -> + Namespace [] ["WaitingBeyondForecastHorizon"] + ChainSync.TraceAccessingForecastHorizon{} -> + Namespace [] ["AccessingForecastHorizon"] + ChainSync.TraceGaveLoPToken{} -> + Namespace [] ["GaveLoPToken"] + ChainSync.TraceOfferJump _ -> + Namespace [] ["OfferJump"] + ChainSync.TraceJumpResult _ -> + Namespace [] ["JumpResult"] + ChainSync.TraceJumpingWaitingForNextInstruction -> + Namespace [] ["JumpingWaitingForNextInstruction"] + ChainSync.TraceJumpingInstructionIs _ -> + Namespace [] ["JumpingInstructionIs"] + ChainSync.TraceDrainingThePipe _ -> + Namespace [] ["DrainingThePipe"] + + severityFor ns _ = + case ns of + Namespace _ ["DownloadedHeader"] -> + Just Info + Namespace _ ["RolledBack"] -> + Just Notice + Namespace _ ["Exception"] -> + Just Warning + Namespace _ ["FoundIntersection"] -> + Just Info + Namespace _ ["Termination"] -> + Just Notice + Namespace _ ["ValidatedHeader"] -> + Just Debug + Namespace _ ["WaitingBeyondForecastHorizon"] -> + Just Debug + Namespace _ ["AccessingForecastHorizon"] -> + Just Debug + Namespace _ ["GaveLoPToken"] -> + Just Debug + Namespace _ ["OfferJump"] -> + Just Debug + Namespace _ ["JumpResult"] -> + Just Debug + Namespace _ ["JumpingWaitingForNextInstruction"] -> + Just Debug + Namespace _ ["JumpingInstructionIs"] -> + Just Debug + Namespace _ ["DrainingThePipe"] -> + Just Debug + _ -> + Nothing + + documentFor ns = + case ns of + Namespace _ ["DownloadedHeader"] -> + Just $ + mconcat + [ "While following a candidate chain, we rolled forward by downloading a" + , " header." + ] + Namespace _ ["RolledBack"] -> + Just "While following a candidate chain, we rolled back to the given point." + Namespace _ ["Exception"] -> + Just "An exception was thrown by the Chain Sync Client." + Namespace _ ["FoundIntersection"] -> + Just $ + mconcat + [ "We found an intersection between our chain fragment and the" + , " candidate's chain." + ] + Namespace _ ["Termination"] -> + Just "The client has terminated." + Namespace _ ["ValidatedHeader"] -> + Just "The header has been validated" + Namespace _ ["WaitingBeyondForecastHorizon"] -> + Just "The slot number is beyond the forecast horizon" + Namespace _ ["AccessingForecastHorizon"] -> + Just "The slot number, which was previously beyond the forecast horizon, has now entered it" + Namespace _ ["GaveLoPToken"] -> + Just "May have added atoken to the LoP bucket of the peer" + Namespace _ ["OfferJump"] -> + Just "Offering a jump to the remote peer" + Namespace _ ["JumpResult"] -> + Just "Response to a jump offer (accept or reject)" + Namespace _ ["JumpingWaitingForNextInstruction"] -> + Just "The client is waiting for the next instruction" + Namespace _ ["JumpingInstructionIs"] -> + Just "The client got its next instruction" + Namespace _ ["DrainingThePipe"] -> + Just "The client is draining the pipe of messages" + _ -> + Nothing + + allNamespaces = + [ Namespace [] ["DownloadedHeader"] + , Namespace [] ["RolledBack"] + , Namespace [] ["Exception"] + , Namespace [] ["FoundIntersection"] + , Namespace [] ["Termination"] + , Namespace [] ["ValidatedHeader"] + , Namespace [] ["WaitingBeyondForecastHorizon"] + , Namespace [] ["AccessingForecastHorizon"] + , Namespace [] ["GaveLoPToken"] + , Namespace [] ["OfferJump"] + , Namespace [] ["JumpResult"] + , Namespace [] ["JumpingWaitingForNextInstruction"] + , Namespace [] ["JumpingInstructionIs"] + , Namespace [] ["DrainingThePipe"] + ] + +-------------------------------------------------------------------------------- +-- ChainSyncServer Tracer +-------------------------------------------------------------------------------- + +instance + ConvertRawHash blk => + LogFormatting (TraceChainSyncServerEvent blk) + where + forMachine dtal (TraceChainSyncServerUpdate tip update blocking enclosing) = + mconcat $ + [ "kind" .= String "ChainSyncServer.Update" + , "tip" .= tipToObject tip + , case update of + AddBlock pt -> "addBlock" .= renderPointForDetails dtal pt + RollBack pt -> "rollBackTo" .= renderPointForDetails dtal pt + , "blockingRead" .= case blocking of Blocking -> True; NonBlocking -> False + ] + <> ["risingEdge" .= True | RisingEdge <- [enclosing]] + + asMetrics (TraceChainSyncServerUpdate _tip (AddBlock _pt) _blocking FallingEdge) = + [CounterM "served.header" Nothing] + asMetrics (TraceChainSyncServerUpdate _tip (AddBlock _pt) _blocking _) = [] + asMetrics _ = [] + +instance MetaTrace (TraceChainSyncServerEvent blk) where + namespaceFor TraceChainSyncServerUpdate{} = Namespace [] ["Update"] + + severityFor + (Namespace _ ["Update"]) + (Just (TraceChainSyncServerUpdate _tip _upd _blocking enclosing)) = + case enclosing of + RisingEdge -> Just Info + FallingEdge -> Just Debug + severityFor (Namespace _ ["Update"]) Nothing = Just Info + severityFor _ _ = Nothing + + metricsDocFor (Namespace _ ["Update"]) = + [ + ( "served.header" + , "A counter triggered only on header event with falling edge" + ) + ] + metricsDocFor _ = [] + + documentFor (Namespace _ ["Update"]) = + Just + "A server read has occurred, either for an add block or a rollback" + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["Update"]] + +-------------------------------------------------------------------------------- +-- BlockFetchClient Metrics +-------------------------------------------------------------------------------- + +data CdfCounter = CdfCounter + { limit :: !Double + , counter :: !Int64 + } + +decCdf :: Double -> CdfCounter -> CdfCounter +decCdf v cdf@CdfCounter{..} + | v < limit = cdf{counter = counter - 1} + | otherwise = cdf + +incCdf :: Double -> CdfCounter -> CdfCounter +incCdf v cdf@CdfCounter{..} + | v < limit = cdf{counter = counter + 1} + | otherwise = cdf + +data ClientMetrics = ClientMetrics + { cmSlotMap :: IntPSQ Word64 NominalDiffTime + , cmCdf1sVar :: !CdfCounter + , cmCdf3sVar :: !CdfCounter + , cmCdf5sVar :: !CdfCounter + , cmDelay :: Double + , cmBlockSize :: Word32 + , cmTraceIt :: Bool + , cmTraceVars :: Bool + } + +instance LogFormatting ClientMetrics where + forMachine _dtal _ = mempty + asMetrics ClientMetrics{cmTraceIt = False} = [] + asMetrics ClientMetrics{..} = + [ DoubleM "blockfetchclient.blockdelay" cmDelay + , IntM "blockfetchclient.blocksize" (fromIntegral cmBlockSize) + ] + ++ lateBlockMetric + ++ if cmTraceVars + then + [ cdfMetric "blockfetchclient.blockdelay.cdfOne" cmCdf1sVar + , cdfMetric "blockfetchclient.blockdelay.cdfThree" cmCdf3sVar + , cdfMetric "blockfetchclient.blockdelay.cdfFive" cmCdf5sVar + ] + else [] + where + size = Pq.size cmSlotMap + cdfMetric name var = DoubleM name (fromIntegral (counter var) / fromIntegral size) + lateBlockMetric = [CounterM "blockfetchclient.lateblocks" Nothing | cmDelay > 5] + +instance MetaTrace ClientMetrics where + namespaceFor _ = Namespace [] ["ClientMetrics"] + severityFor _ _ = Just Debug + documentFor (Namespace _ ["ClientMetrics"]) = + Just + "Block fetch client metrics, recomputed on every completed block fetch: the\ + \ size and delay of the last block, how many fetches ran late, and the\ + \ distribution of fetch delays." + documentFor _ = Nothing + + metricsDocFor (Namespace _ ["ClientMetrics"]) = + [ ("blockfetchclient.blockdelay", "delay (s) of the latest block fetch") + , ("blockfetchclient.blocksize", "block size (bytes) of the latest block fetch") + , ("blockfetchclient.lateblocks", "number of block fetches that took longer than 5s") + , ("blockfetchclient.blockdelay.cdfOne", "probability for block fetch to complete within 1s") + , ("blockfetchclient.blockdelay.cdfThree", "probability for block fetch to complete within 3s") + , ("blockfetchclient.blockdelay.cdfFive", "probability for block fetch to complete within 5s") + ] + metricsDocFor _ = [] + + allNamespaces = + [ Namespace [] ["ClientMetrics"] + ] + +initialClientMetrics :: ClientMetrics +initialClientMetrics = + ClientMetrics + Pq.empty + (CdfCounter 1 0) + (CdfCounter 3 0) + (CdfCounter 5 0) + 0 + 0 + False + False + +calculateBlockFetchClientMetrics :: + ClientMetrics -> + LoggingContext -> + BlockFetch.TraceLabelPeer peer (BlockFetch.TraceFetchClientState header) -> + ClientMetrics +calculateBlockFetchClientMetrics + cm@ClientMetrics{..} + _lc + (TraceLabelPeer _ (BlockFetch.CompletedBlockFetch p _ _ _ forgeDelay blockSize)) = + case pointSlot p of + Origin -> nothingToDo + At (SlotNo slotNo) -> + if Pq.null cmSlotMap && forgeDelay > 20 -- During startup wait until we are in sync + then nothingToDo + else processSlot slotNo + where + nothingToDo = cm{cmTraceIt = False} + delay = realToFrac forgeDelay + + processSlot slotNo + | fromIntegral slotNo `Pq.member` cmSlotMap = nothingToDo -- Duplicate, only track the first + | otherwise = + let slotMap' = Pq.insert (fromIntegral slotNo) slotNo forgeDelay cmSlotMap + in if Pq.size slotMap' > 1080 -- TODO: k/2, should come from config file + then trimSlotMap slotMap' slotNo + else updateMetrics slotMap' + + trimSlotMap slotMap' slotNo = case Pq.minView slotMap' of + Nothing -> nothingToDo -- Error: Just inserted element + Just (_, minSlotNo, realToFrac -> minDelay, slotMap'') + | minSlotNo == slotNo -> nothingToDo + | otherwise -> + cm + { cmCdf1sVar = adjust minDelay cmCdf1sVar + , cmCdf3sVar = adjust minDelay cmCdf3sVar + , cmCdf5sVar = adjust minDelay cmCdf5sVar + , cmDelay = delay + , cmBlockSize = getSizeInBytes blockSize + , cmTraceVars = True + , cmTraceIt = True + , cmSlotMap = slotMap'' + } + + updateMetrics slotMap' = + cm + { cmCdf1sVar = update cmCdf1sVar + , cmCdf3sVar = update cmCdf3sVar + , cmCdf5sVar = update cmCdf5sVar + , cmDelay = delay + , cmBlockSize = getSizeInBytes blockSize + , cmTraceVars = Pq.size cmSlotMap >= 45 -- wait until we have at least 45 samples before providing cdf estimates + , cmTraceIt = True + , cmSlotMap = slotMap' + } + + update = incCdf delay + adjust d = update . decCdf d +calculateBlockFetchClientMetrics cm _lc _ = cm + +-------------------------------------------------------------------------------- +-- BlockFetchDecision Tracer +-------------------------------------------------------------------------------- + +instance MetaTrace (TraceDecisionEvent peer (Header blk)) where + namespaceFor PeersFetch{} = Namespace [] ["PeersFetch"] + namespaceFor PeerStarvedUs{} = Namespace [] ["PeerStarvedUs"] + + severityFor (Namespace _ ["PeersFetch"]) _ = Just Debug + severityFor (Namespace _ ["PeerStarvedUs"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace [] ["PeersFetch"]) = + Just "list of block-fetch decisions" + documentFor (Namespace [] ["PeerStarvedUs"]) = + Just "current peer starved us, the node will switch to a different peer" + documentFor _ = Nothing + + allNamespaces = + [Namespace [] ["PeersFetch"], Namespace [] ["PeerStarvedUs"]] + +instance + (Show peer, ToJSON peer, LogFormatting peer, HasHeader blk) => + LogFormatting (TraceDecisionEvent peer (Header blk)) + where + forHuman = Text.pack . show + + forMachine dtal (PeersFetch xs) = + mconcat + [ "kind" .= String "PeerFetch" + , "decisions" .= map (forMachine dtal) xs + ] + forMachine _dtal (PeerStarvedUs peer) = + mconcat + [ "kind" .= String "PeerStarvedUs" + , "peer" .= toJSON peer + ] + +instance LogFormatting (FetchDecision [Point header]) where + forMachine _dtal (Left decline) = + mconcat + [ "kind" .= String "FetchDecision declined" + , "declined" .= String (showT decline) + ] + forMachine _dtal (Right results) = + mconcat + [ "kind" .= String "FetchDecision results" + , "length" .= String (showT $ length results) + ] + +-------------------------------------------------------------------------------- +-- BlockFetchClientState Tracer +-------------------------------------------------------------------------------- + +instance + (HasHeader header, ConvertRawHash header) => + LogFormatting (BlockFetch.TraceFetchClientState header) + where + forMachine _dtal BlockFetch.AddedFetchRequest{} = + mconcat ["kind" .= String "AddedFetchRequest"] + forMachine _dtal BlockFetch.AcknowledgedFetchRequest{} = + mconcat ["kind" .= String "AcknowledgedFetchRequest"] + forMachine dtal (BlockFetch.SendFetchRequest af gsv) = + mconcat $ + [ "kind" .= String "SendFetchRequest" + , "head" + .= String + ( renderChainHash + (renderHeaderHash (Proxy @header)) + (AF.headHash af) + ) + , "length" .= toJSON (fragmentLength' af) + ] + ++ ["deltaq" .= toJSON gsv | dtal >= DDetailed] + where + -- NOTE: this ignores the Byron era with its EBB complication: + -- the length would be underestimated by 1, if the AF is anchored + -- at the epoch boundary. + fragmentLength' :: AF.AnchoredFragment header -> Int + fragmentLength' f = fromIntegral . unBlockNo $ + case (f, f) of + (AS.Empty{}, AS.Empty{}) -> 0 + (firstHdr AS.:< _, _ AS.:> lastHdr) -> + blockNo lastHdr - blockNo firstHdr + 1 + forMachine _dtal (BlockFetch.CompletedBlockFetch pt _ _ _ delay blockSize) = + mconcat + [ "kind" .= String "CompletedBlockFetch" + , "delay" .= (realToFrac delay :: Double) + , "size" .= getSizeInBytes blockSize + , "block" + .= String + ( case pt of + GenesisPoint -> "Genesis" + BlockPoint _ h -> renderHeaderHash (Proxy @header) h + ) + ] + forMachine _dtal BlockFetch.CompletedFetchBatch{} = + mconcat ["kind" .= String "CompletedFetchBatch"] + forMachine _dtal BlockFetch.StartedFetchBatch{} = + mconcat ["kind" .= String "StartedFetchBatch"] + forMachine _dtal BlockFetch.RejectedFetchBatch{} = + mconcat ["kind" .= String "RejectedFetchBatch"] + forMachine _dtal (BlockFetch.ClientTerminating outstanding) = + mconcat + [ "kind" .= String "ClientTerminating" + , "outstanding" .= outstanding + ] + +instance MetaTrace (BlockFetch.TraceFetchClientState header) where + namespaceFor BlockFetch.AddedFetchRequest{} = + Namespace [] ["AddedFetchRequest"] + namespaceFor BlockFetch.AcknowledgedFetchRequest{} = + Namespace [] ["AcknowledgedFetchRequest"] + namespaceFor BlockFetch.SendFetchRequest{} = + Namespace [] ["SendFetchRequest"] + namespaceFor BlockFetch.StartedFetchBatch{} = + Namespace [] ["StartedFetchBatch"] + namespaceFor BlockFetch.CompletedFetchBatch{} = + Namespace [] ["CompletedFetchBatch"] + namespaceFor BlockFetch.CompletedBlockFetch{} = + Namespace [] ["CompletedBlockFetch"] + namespaceFor BlockFetch.RejectedFetchBatch{} = + Namespace [] ["RejectedFetchBatch"] + namespaceFor BlockFetch.ClientTerminating{} = + Namespace [] ["ClientTerminating"] + + severityFor (Namespace _ ["AddedFetchRequest"]) _ = Just Info + severityFor (Namespace _ ["AcknowledgedFetchRequest"]) _ = Just Info + severityFor (Namespace _ ["SendFetchRequest"]) _ = Just Info + severityFor (Namespace _ ["StartedFetchBatch"]) _ = Just Info + severityFor (Namespace _ ["CompletedFetchBatch"]) _ = Just Info + severityFor (Namespace _ ["CompletedBlockFetch"]) _ = Just Info + severityFor (Namespace _ ["RejectedFetchBatch"]) _ = Just Info + severityFor (Namespace _ ["ClientTerminating"]) _ = Just Notice + severityFor _ _ = Nothing + + documentFor (Namespace _ ["AddedFetchRequest"]) = + Just $ + mconcat + [ "The block fetch decision thread has added a new fetch instruction" + , " consisting of one or more individual request ranges." + ] + documentFor (Namespace _ ["AcknowledgedFetchRequest"]) = + Just $ + mconcat + [ "Mark the point when the fetch client picks up the request added" + , " by the block fetch decision thread. Note that this event can happen" + , " fewer times than the 'AddedFetchRequest' due to fetch request merging." + ] + documentFor (Namespace _ ["SendFetchRequest"]) = + Just $ + mconcat + [ "Mark the point when fetch request for a fragment is actually sent" + , " over the wire." + ] + documentFor (Namespace _ ["StartedFetchBatch"]) = + Just $ + mconcat + [ "Mark the start of receiving a streaming batch of blocks. This will" + , " be followed by one or more 'CompletedBlockFetch' and a final" + , " 'CompletedFetchBatch'" + ] + documentFor (Namespace _ ["CompletedFetchBatch"]) = + Just + "Mark the successful end of receiving a streaming batch of blocks." + documentFor (Namespace _ ["CompletedBlockFetch"]) = + Just + "" + documentFor (Namespace _ ["RejectedFetchBatch"]) = + Just $ + mconcat + [ "If the other peer rejects our request then we have this event" + , " instead of 'StartedFetchBatch' and 'CompletedFetchBatch'." + ] + documentFor (Namespace _ ["ClientTerminating"]) = + Just $ + mconcat + [ "The client is terminating. Log the number of outstanding" + , " requests." + ] + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["AddedFetchRequest"] + , Namespace [] ["AcknowledgedFetchRequest"] + , Namespace [] ["SendFetchRequest"] + , Namespace [] ["StartedFetchBatch"] + , Namespace [] ["CompletedFetchBatch"] + , Namespace [] ["CompletedBlockFetch"] + , Namespace [] ["RejectedFetchBatch"] + , Namespace [] ["ClientTerminating"] + ] + +-------------------------------------------------------------------------------- +-- BlockFetchServerEvent +-------------------------------------------------------------------------------- + +instance ConvertRawHash blk => LogFormatting (TraceBlockFetchServerEvent blk) where + forMachine _dtal (TraceBlockFetchServerSendBlock blk) = + mconcat + [ "kind" .= String "BlockFetchServer" + , "block" + .= String + ( renderChainHash + @blk + (renderHeaderHash (Proxy @blk)) + $ pointHash blk + ) + ] + asMetrics (TraceBlockFetchServerSendBlock _p) = + [CounterM "served.block" Nothing] + +instance MetaTrace (TraceBlockFetchServerEvent blk) where + namespaceFor TraceBlockFetchServerSendBlock{} = + Namespace [] ["SendBlock"] + + severityFor (Namespace [] ["SendBlock"]) _ = + Just + Info + severityFor _ _ = Nothing + + metricsDocFor (Namespace [] ["SendBlock"]) = + [ ("served.block", "This counter metric indicates how many blocks this node has served.") + , + ( "served.block.latest" + , "This counter metric indicates how many chain tip blocks this node has served." + ) + ] + metricsDocFor _ = [] + + documentFor (Namespace [] ["SendBlock"]) = + Just + "The server sent a block to the peer." + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["SendBlock"]] + +-------------------------------------------------------------------------------- +-- Metric for server block latest +-- Only traces to EKG, no complete tracer! +-------------------------------------------------------------------------------- + +data ServedBlock = ServedBlock + { maxSlotNo :: SlotNo + , localUp :: Word64 + , servedBlocksLatest :: Word64 + } + +instance LogFormatting ServedBlock where + forMachine _mDtal ServedBlock{} = mempty + + asMetrics ServedBlock{..} = + [IntM "served.block.latest" (fromIntegral servedBlocksLatest)] + +emptyServedBlocks :: ServedBlock +emptyServedBlocks = ServedBlock 0 0 0 + +servedBlockLatest :: + Maybe (Trace IO FormattedMessage) -> + IO (Trace IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk))) +servedBlockLatest mbTrEKG = + foldTraceM + calculateServedBlockLatest + emptyServedBlocks + ( metricsFormatter + (mkMetricsTracer mbTrEKG) + ) + +calculateServedBlockLatest :: + Monad m => + ServedBlock -> + LoggingContext -> + TraceLabelPeer peer (TraceBlockFetchServerEvent blk) -> + m ServedBlock +calculateServedBlockLatest ServedBlock{..} _lc (TraceLabelPeer _ (TraceBlockFetchServerSendBlock p)) = + case pointSlot p of + Origin -> return $ ServedBlock maxSlotNo localUp servedBlocksLatest + At slotNo -> + case compare maxSlotNo slotNo of + LT -> return $ ServedBlock slotNo (localUp + 1) (localUp + 1) + GT -> return $ ServedBlock maxSlotNo localUp servedBlocksLatest + EQ -> return $ ServedBlock maxSlotNo (localUp + 1) (localUp + 1) + +-------------------------------------------------------------------------------- +-- Gdd Tracer +-------------------------------------------------------------------------------- + +instance + ( LogFormatting peer + , HasHeader blk + , HasHeader (Header blk) + , ConvertRawHash (Header blk) + ) => + LogFormatting (TraceGDDEvent peer blk) + where + forMachine dtal (TraceGDDDebug (GDDDebugInfo{..})) = + mconcat $ + [ "kind" .= String "TraceGDDDebugInfo" + , "losingPeers" .= toJSON (map (forMachine dtal) losingPeers) + , "loeHead" .= forMachine dtal loeHead + , "sgen" .= toJSON (unGenesisWindow sgen) + ] + <> do + guard $ dtal >= DMaximum + [ "bounds" + .= toJSON + ( map + ( \(peer, density) -> + Aeson.object + [ "kind" .= String "PeerDensityBound" + , "peer" .= forMachine dtal peer + , "densityBounds" .= forMachine dtal density + ] + ) + bounds + ) + , "curChain" .= forMachine dtal curChain + , "candidates" + .= toJSON + ( map + ( \(peer, frag) -> + Aeson.object + [ "kind" .= String "PeerCandidateFragment" + , "peer" .= forMachine dtal peer + , "candidateFragment" .= forMachine dtal frag + ] + ) + candidates + ) + , "candidateSuffixes" + .= toJSON + ( map + ( \(peer, frag) -> + Aeson.object + [ "kind" .= String "PeerCandidateSuffix" + , "peer" .= forMachine dtal peer + , "candidateSuffix" .= forMachine dtal frag + ] + ) + candidateSuffixes + ) + ] + forMachine dtal (TraceGDDDisconnected peers) = + mconcat + [ "kind" .= String "TraceGDDDisconnected" + , "peers" .= toJSON (map (forMachine dtal) (toList peers)) + ] + +instance MetaTrace (TraceGDDEvent peer blk) where + namespaceFor _ = Namespace [] ["TraceGDDEvent"] + + severityFor _ _ = Just Debug + + documentFor _ = Just "The Genesis Density Disconnection governor has updated its state" + + allNamespaces = [Namespace [] ["TraceGDDEvent"]] + +instance + ( HasHeader blk + , HasHeader (Header blk) + , ConvertRawHash (Header blk) + ) => + LogFormatting (DensityBounds blk) + where + forMachine dtal DensityBounds{..} = + mconcat + [ "kind" .= String "DensityBounds" + , "clippedFragment" .= forMachine dtal clippedFragment + , "offersMoreThanK" .= toJSON offersMoreThanK + , "lowerBound" .= toJSON lowerBound + , "upperBound" .= toJSON upperBound + , "hasBlockAfter" .= toJSON hasBlockAfter + , "latestSlot" .= toJSON (unSlotNo <$> withOriginToMaybe latestSlot) + , "idling" .= toJSON idling + ] + +-------------------------------------------------------------------------------- +-- SanityCheckIssue Tracer +-------------------------------------------------------------------------------- + +instance MetaTrace SanityCheckIssue where + namespaceFor _ = Namespace [] ["SanityCheckIssue"] + + severityFor (Namespace _ ["SanityCheckIssue"]) _ = Just Error + severityFor _ _ = Nothing + + documentFor (Namespace _ ["SanityCheckIssue"]) = + Just $ + mconcat + [ "A sanity check on the node configuration found a suspicious setting at" + , " startup. The `kind` field names the check that fired:" + , " `InconsistentSecurityParam`, `SnapshotDelayRangeInverted`," + , " `SnapshotDelayRangeNegativeMinimum`, `SnapshotRateLimitDisabled`," + , " `SnapshotRateLimitSuspiciouslyLarge`, `SnapshotNumZero` or" + , " `SnapshotIntervalNotDivisorOfEpoch`. These flag configurations that are" + , " legal but almost certainly unintended; the node continues to run." + ] + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["SanityCheckIssue"]] + +instance LogFormatting SanityCheckIssue where + forMachine _dtal (InconsistentSecurityParam e) = + mconcat + [ "kind" .= String "InconsistentSecurityParam" + , "error" .= String (Text.pack $ show e) + ] + forMachine _dtal (SnapshotDelayRangeInverted mn mx) = + mconcat + [ "kind" .= String "SnapshotDelayRangeInverted" + , "minimumDelay" .= show mn + , "maximumDelay" .= show mx + ] + forMachine _dtal (SnapshotDelayRangeNegativeMinimum mn) = + mconcat + [ "kind" .= String "SnapshotDelayRangeNegativeMinimum" + , "minimumDelay" .= show mn + ] + forMachine _dtal SnapshotRateLimitDisabled = + mconcat + [ "kind" .= String "SnapshotRateLimitDisabled" + ] + forMachine _dtal (SnapshotRateLimitSuspiciouslyLarge rl) = + mconcat + [ "kind" .= String "SnapshotRateLimitSuspiciouslyLarge" + , "rateLimit" .= show rl + ] + forMachine _dtal SnapshotNumZero = + mconcat + [ "kind" .= String "SnapshotNumZero" + ] + forMachine _dtal (SnapshotIntervalNotDivisorOfEpoch interval) = + mconcat + [ "kind" .= String "SnapshotIntervalNotDivisorOfEpoch" + , "interval" .= toJSON interval + ] + forHuman = Text.pack . displayException + +-------------------------------------------------------------------------------- +-- TxSubmissionServer Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting (TraceLocalTxSubmissionServerEvent blk) where + forMachine _dtal (TraceReceivedTx _gtx) = + mconcat ["kind" .= String "ReceivedTx"] + +instance MetaTrace (TraceLocalTxSubmissionServerEvent blk) where + namespaceFor TraceReceivedTx{} = + Namespace [] ["ReceivedTx"] + + severityFor (Namespace _ ["ReceivedTx"]) _ = + Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ReceivedTx"]) = + Just + "A transaction was received." + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["ReceivedTx"] + ] + +-------------------------------------------------------------------------------- +-- Mempool Tracer +-------------------------------------------------------------------------------- + +txsMempoolTimeoutSoftCounterName :: Text.Text +txsMempoolTimeoutSoftCounterName = "txsMempoolTimeoutSoft" + +txsSyncDurationTotalCounterName :: Text.Text +txsSyncDurationTotalCounterName = "txsSyncDurationTotal" + +impliesMempoolTimeoutSoft :: TraceEventMempool blk -> Bool +impliesMempoolTimeoutSoft = \case + TraceMempoolRejectedTx _tx _txApplyErr details _mpSz -> + case details of + MempoolRejectedByTimeoutSoft{} -> True + MempoolRejectedByLedger -> False + _ -> False + +instance + ( LogFormatting (ApplyTxErr blk) + , LogFormatting (GenTx blk) + , Show (GenTxId blk) + , ConvertTxId blk + , LedgerSupportsMempool blk + , ConvertRawHash blk + ) => + LogFormatting (TraceEventMempool blk) + where + forMachine dtal (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) = + mconcat + [ "kind" .= String "TraceMempoolAddedTx" + , "tx" .= forMachine dtal (txForgetValidated tx) + , "mempoolSize" .= forMachine dtal mpSzAfter + ] + forMachine dtal (TraceMempoolRejectedTx tx txApplyErr details mpSz) = + mconcat $ + [ "kind" .= String "TraceMempoolRejectedTx" + , "tx" .= forMachine dtal tx + , "mempoolSize" .= forMachine dtal mpSz + , "errdetails" .= jsonMempoolRejectionDetails details + ] + <> if dtal < DDetailed + then [] + else + [ "err" .= forMachine dtal txApplyErr + ] + forMachine dtal (TraceMempoolRemoveTxs txs mpSz) = + mconcat + [ "kind" .= String "TraceMempoolRemoveTxs" + , "txs" + .= map + ( \(tx, err) -> + Aeson.object $ + [ "tx" .= forMachine dtal tx + ] + <> [ "err" .= forMachine dtal err + | dtal >= DDetailed + ] + ) + txs + , "mempoolSize" .= forMachine dtal mpSz + ] + forMachine dtal (TraceMempoolManuallyRemovedTxs txs0 txs1 mpSz) = + mconcat + [ "kind" .= String "TraceMempoolManuallyRemovedTxs" + , "txsRemoved" .= map (String . renderTxIdForDetails dtal) (toList txs0) + , "txsInvalidated" .= map (forMachine dtal) txs1 + , "mempoolSize" .= forMachine dtal mpSz + ] + forMachine dtal (TraceMempoolSyncNotNeeded t) = + mconcat + [ "kind" .= String "TraceMempoolSyncNotNeeded" + , "tip" .= forMachine dtal t + ] + forMachine dtal (TraceMempoolAttemptingAdd tx) = + mconcat + [ "kind" .= String "TraceMempoolAttemptingAdd" + , "tx" .= forMachine dtal tx + ] + forMachine _dtal (TraceMempoolSynced et) = + mconcat + [ "kind" .= String "TraceMempoolSynced" + , "enclosingTime" .= enclosingValue et + ] + forMachine _dtal TraceMempoolTipMovedBetweenSTMBlocks = + mconcat + [ "kind" .= String "TraceMempoolTipMovedBetweenSTMBlocks" + ] + forMachine _dtal (TraceMempoolCapacityChanged capBefore capAfter) = + mconcat + [ "kind" .= String "TraceMempoolCapacityChanged" + , "capacityBefore" .= jsonTxMeasure capBefore + , "capacityAfter" .= jsonTxMeasure capAfter + ] + + asMetrics (TraceMempoolAddedTx _tx _mpSzBefore mpSz) = + [ IntM "txsInMempool" (fromIntegral $ msNumTxs mpSz) + , IntM "mempoolBytes" (fromIntegral . unByteSize32 . msNumBytes $ mpSz) + ] + asMetrics ev@(TraceMempoolRejectedTx _tx _txApplyErr _details mpSz) = + [ IntM "txsInMempool" (fromIntegral $ msNumTxs mpSz) + , IntM "mempoolBytes" (fromIntegral . unByteSize32 . msNumBytes $ mpSz) + ] + ++ [ CounterM txsMempoolTimeoutSoftCounterName Nothing + | impliesMempoolTimeoutSoft ev + ] + asMetrics (TraceMempoolRemoveTxs txs mpSz) = + [ IntM "txsInMempool" (fromIntegral $ msNumTxs mpSz) + , IntM "mempoolBytes" (fromIntegral . unByteSize32 . msNumBytes $ mpSz) + , CounterM "txsProcessedNum" (Just (length txs)) + ] + asMetrics (TraceMempoolManuallyRemovedTxs _txs _txs1 mpSz) = + [ IntM "txsInMempool" (fromIntegral $ msNumTxs mpSz) + , IntM "mempoolBytes" (fromIntegral . unByteSize32 . msNumBytes $ mpSz) + ] + asMetrics (TraceMempoolSynced (FallingEdgeWith duration)) = + let durationMs = round (1000 * duration) :: Integer + in [ IntM "txsSyncDuration" durationMs + , CounterM txsSyncDurationTotalCounterName (Just (fromIntegral durationMs)) + ] + asMetrics (TraceMempoolSynced RisingEdge) = [] + asMetrics TraceMempoolSyncNotNeeded{} = [] + asMetrics TraceMempoolAttemptingAdd{} = [] + asMetrics TraceMempoolTipMovedBetweenSTMBlocks{} = [] + asMetrics TraceMempoolCapacityChanged{} = [] + +jsonTxMeasure :: (TxMeasurePhase1Metrics m, TxMeasurePhase2Metrics m) => m -> Value +jsonTxMeasure m = + Aeson.object + [ "txSizeBytes" .= unByteSize32 (txMeasureMetricTxSizeBytes m) + , "exUnitsMemory" .= txMeasureMetricExUnitsMemory m + , "exUnitsSteps" .= txMeasureMetricExUnitsSteps m + , "refScriptsSizeBytes" .= unByteSize32 (txMeasureMetricRefScriptsSizeBytes m) + ] + +instance LogFormatting MempoolSize where + forMachine _dtal MempoolSize{msNumTxs, msNumBytes} = + mconcat + [ "numTxs" .= msNumTxs + , "bytes" .= unByteSize32 msNumBytes + ] + +instance MetaTrace (TraceEventMempool blk) where + namespaceFor TraceMempoolAddedTx{} = Namespace [] ["AddedTx"] + namespaceFor TraceMempoolRejectedTx{} = Namespace [] ["RejectedTx"] + namespaceFor TraceMempoolRemoveTxs{} = Namespace [] ["RemoveTxs"] + namespaceFor TraceMempoolManuallyRemovedTxs{} = Namespace [] ["ManuallyRemovedTxs"] + namespaceFor TraceMempoolSynced{} = Namespace [] ["Synced"] + namespaceFor TraceMempoolSyncNotNeeded{} = Namespace [] ["SyncNotNeeded"] + namespaceFor TraceMempoolAttemptingAdd{} = Namespace [] ["AttemptAdd"] + namespaceFor TraceMempoolTipMovedBetweenSTMBlocks{} = Namespace [] ["TipMovedBetweenSTMBlocks"] + namespaceFor TraceMempoolCapacityChanged{} = Namespace [] ["CapacityChanged"] + + severityFor (Namespace _ ["AddedTx"]) _ = Just Info + severityFor (Namespace _ ["RejectedTx"]) _ = Just Info + severityFor (Namespace _ ["RemoveTxs"]) _ = Just Info + severityFor (Namespace _ ["Synced"]) _ = Just Debug + severityFor (Namespace _ ["ManuallyRemovedTxs"]) _ = Just Warning + severityFor (Namespace _ ["SyncNotNeeded"]) _ = Just Debug + severityFor (Namespace _ ["AttemptAdd"]) _ = Just Debug + severityFor (Namespace [] ["TipMovedBetweenSTMBlocks"]) _ = Just Debug + severityFor (Namespace _ ["CapacityChanged"]) _ = Just Debug + severityFor _ _ = Nothing + + metricsDocFor (Namespace _ ["AddedTx"]) = + [ ("txsInMempool", "Transactions in mempool") + , ("mempoolBytes", "Byte size of the mempool") + ] + metricsDocFor (Namespace _ ["RejectedTx"]) = + [ ("txsInMempool", "Transactions in mempool") + , ("mempoolBytes", "Byte size of the mempool") + , (txsMempoolTimeoutSoftCounterName, "Transactions that soft timed out in mempool") + ] + metricsDocFor (Namespace _ ["RemoveTxs"]) = + [ ("txsInMempool", "Transactions in mempool") + , ("mempoolBytes", "Byte size of the mempool") + ] + metricsDocFor (Namespace _ ["ManuallyRemovedTxs"]) = + [ ("txsInMempool", "Transactions in mempool") + , ("mempoolBytes", "Byte size of the mempool") + , ("txsProcessedNum", "") + ] + metricsDocFor (Namespace _ ["Synced"]) = + [ ("txsSyncDuration", "Latest time to sync the mempool in ms after block adoption") + , + ( txsSyncDurationTotalCounterName + , "Cumulative time spent syncing the mempool in ms after block adoption" + ) + ] + metricsDocFor _ = [] + + documentFor (Namespace _ ["AddedTx"]) = + Just + "New, valid transaction that was added to the Mempool." + documentFor (Namespace _ ["RejectedTx"]) = + Just $ + mconcat + [ "New, invalid transaction that was rejected and thus not added to" + , " the Mempool." + ] + documentFor (Namespace _ ["RemoveTxs"]) = + Just $ + mconcat + [ "Previously valid transactions that are no longer valid because of" + , " changes in the ledger state. These transactions have been removed" + , " from the Mempool." + ] + documentFor (Namespace _ ["ManuallyRemovedTxs"]) = + Just + "Transactions that have been manually removed from the Mempool." + documentFor (Namespace _ ["SyncNotNeeded"]) = + Just + "The mempool and the LedgerDB are in sync already." + documentFor (Namespace _ ["Synced"]) = + Just + "The mempool and the LedgerDB are syncing or in sync depending on the argument on the trace." + documentFor (Namespace _ ["AttemptAdd"]) = + Just + "Mempool is about to try to validate and add a transaction." + documentFor (Namespace _ ["TipMovedBetweenSTMBlocks"]) = + Just + "LedgerDB moved to an alternative fork between two reads during re-sync." + documentFor (Namespace _ ["CapacityChanged"]) = + Just + "The mempool capacity has changed when re-syncing the mempool to the latest tip" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["AddedTx"] + , Namespace [] ["RejectedTx"] + , Namespace [] ["RemoveTxs"] + , Namespace [] ["ManuallyRemovedTxs"] + , Namespace [] ["Synced"] + , Namespace [] ["SyncNotNeeded"] + , Namespace [] ["AttemptAdd"] + , Namespace [] ["TipMovedBetweenSTMBlocks"] + , Namespace [] ["CapacityChanged"] + ] + +-------------------------------------------------------------------------------- +-- ForgeEvent Tracer +-------------------------------------------------------------------------------- + +instance + ( tx ~ GenTx blk + , ConvertRawHash blk + , GetHeader blk + , HasHeader blk + , HasKESInfo blk + , HasTxId (GenTx blk) + , LedgerSupportsProtocol blk + , LedgerSupportsMempool blk + , SerialiseNodeToNodeConstraints blk + , Show (ForgeStateUpdateError blk) + , Show (CannotForge blk) + , Show (TxId (GenTx blk)) + , Show (PerasError blk) + , LogFormatting (CannotForge blk) + , LogFormatting (ExtValidationError blk) + , LogFormatting (ForgeStateUpdateError blk) + ) => + LogFormatting (TraceForgeEvent blk) + where + forMachine _dtal (TraceStartLeadershipCheck slotNo) = + mconcat + [ "kind" .= String "TraceStartLeadershipCheck" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine dtal (TraceSlotIsImmutable slotNo tipPoint tipBlkNo) = + mconcat + [ "kind" .= String "TraceSlotIsImmutable" + , "slot" .= toJSON (unSlotNo slotNo) + , "tip" .= renderPointForDetails dtal tipPoint + , "tipBlockNo" .= toJSON (unBlockNo tipBlkNo) + ] + forMachine _dtal (TraceBlockFromFuture currentSlot tip) = + mconcat + [ "kind" .= String "TraceBlockFromFuture" + , "current slot" .= toJSON (unSlotNo currentSlot) + , "tip" .= toJSON (unSlotNo tip) + ] + forMachine dtal (TraceBlockContext currentSlot tipBlkNo tipPoint) = + mconcat + [ "kind" .= String "TraceBlockContext" + , "current slot" .= toJSON (unSlotNo currentSlot) + , "tip" .= renderPointForDetails dtal tipPoint + , "tipBlockNo" .= toJSON (unBlockNo tipBlkNo) + ] + forMachine _dtal (TraceNoLedgerState slotNo _pt) = + mconcat + [ "kind" .= String "TraceNoLedgerState" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceLedgerState slotNo _pt) = + mconcat + [ "kind" .= String "TraceLedgerState" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceNoLedgerView slotNo _) = + mconcat + [ "kind" .= String "TraceNoLedgerView" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceLedgerView slotNo) = + mconcat + [ "kind" .= String "TraceLedgerView" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine dtal (TraceForgeStateUpdateError slotNo reason) = + mconcat + [ "kind" .= String "TraceForgeStateUpdateError" + , "slot" .= toJSON (unSlotNo slotNo) + , "reason" .= forMachine dtal reason + ] + forMachine dtal (TraceNodeCannotForge slotNo reason) = + mconcat + [ "kind" .= String "TraceNodeCannotForge" + , "slot" .= toJSON (unSlotNo slotNo) + , "reason" .= forMachine dtal reason + ] + forMachine _dtal (TraceNodeNotLeader slotNo) = + mconcat + [ "kind" .= String "TraceNodeNotLeader" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceNodeIsLeader slotNo) = + mconcat + [ "kind" .= String "TraceNodeIsLeader" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine dtal (TraceForgeTickedLedgerState slotNo prevPt) = + mconcat + [ "kind" .= String "TraceForgeTickedLedgerState" + , "slot" .= toJSON (unSlotNo slotNo) + , "prev" .= renderPointForDetails dtal prevPt + ] + forMachine dtal (TraceForgingMempoolSnapshot slotNo prevPt mpHash mpSlot) = + mconcat + [ "kind" .= String "TraceForgingMempoolSnapshot" + , "slot" .= toJSON (unSlotNo slotNo) + , "prev" .= renderPointForDetails dtal prevPt + , "mempoolHash" .= String (renderChainHash @blk (renderHeaderHash (Proxy @blk)) mpHash) + , "mempoolSlot" .= toJSON (unSlotNo mpSlot) + ] + forMachine _dtal (TraceForgedBlock slotNo _ blk _ _) = + mconcat + [ "kind" .= String "TraceForgedBlock" + , "slot" .= toJSON (unSlotNo slotNo) + , "block" .= String (renderHeaderHash (Proxy @blk) $ blockHash blk) + , "blockNo" .= toJSON (unBlockNo $ blockNo blk) + , "blockPrev" + .= String + ( renderChainHash + @blk + (renderHeaderHash (Proxy @blk)) + $ blockPrevHash blk + ) + ] + forMachine _dtal (TraceDidntAdoptBlock slotNo _) = + mconcat + [ "kind" .= String "TraceDidntAdoptBlock" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine dtal (TraceForgedInvalidBlock slotNo _ reason) = + mconcat + [ "kind" .= String "TraceForgedInvalidBlock" + , "slot" .= toJSON (unSlotNo slotNo) + , "reason" .= forMachine dtal reason + ] + forMachine DDetailed (TraceAdoptedBlock slotNo blk txs) = + mconcat + [ "kind" .= String "TraceAdoptedBlock" + , "slot" .= toJSON (unSlotNo slotNo) + , "blockHash" + .= renderHeaderHashForDetails + (Proxy @blk) + DDetailed + (blockHash blk) + , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk)) + , "txIds" .= toJSON (map (show . txId . txForgetValidated) txs) + ] + forMachine dtal (TraceAdoptedBlock slotNo blk _txs) = + mconcat + [ "kind" .= String "TraceAdoptedBlock" + , "slot" .= toJSON (unSlotNo slotNo) + , "blockHash" + .= renderHeaderHashForDetails + (Proxy @blk) + dtal + (blockHash blk) + , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk)) + ] + forMachine dtal (TraceAdoptionThreadDied slotNo blk) = + mconcat + [ "kind" .= String "TraceAdoptionThreadDied" + , "slot" .= toJSON (unSlotNo slotNo) + , "blockHash" + .= renderHeaderHashForDetails + (Proxy @blk) + dtal + (blockHash blk) + , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk)) + ] + + forHuman (TraceStartLeadershipCheck slotNo) = + "Checking for leadership in slot " <> showT (unSlotNo slotNo) + forHuman (TraceSlotIsImmutable slotNo immutableTipPoint immutableTipBlkNo) = + "Couldn't forge block because current slot is immutable: " + <> "immutable tip: " + <> renderPointAsPhrase immutableTipPoint + <> ", immutable tip block no: " + <> showT (unBlockNo immutableTipBlkNo) + <> ", current slot: " + <> showT (unSlotNo slotNo) + forHuman (TraceBlockFromFuture currentSlot tipSlot) = + "Couldn't forge block because current tip is in the future: " + <> "current tip slot: " + <> showT (unSlotNo tipSlot) + <> ", current slot: " + <> showT (unSlotNo currentSlot) + forHuman (TraceBlockContext currentSlot tipBlockNo tipPoint) = + "New block will fit onto: " + <> "tip: " + <> renderPointAsPhrase tipPoint + <> ", tip block no: " + <> showT (unBlockNo tipBlockNo) + <> ", current slot: " + <> showT (unSlotNo currentSlot) + forHuman (TraceNoLedgerState slotNo pt) = + "Could not obtain ledger state for point " + <> renderPointAsPhrase pt + <> ", current slot: " + <> showT (unSlotNo slotNo) + forHuman (TraceLedgerState slotNo pt) = + "Obtained a ledger state for point " + <> renderPointAsPhrase pt + <> ", current slot: " + <> showT (unSlotNo slotNo) + forHuman (TraceNoLedgerView slotNo _) = + "Could not obtain ledger view for slot " <> showT (unSlotNo slotNo) + forHuman (TraceLedgerView slotNo) = + "Obtained a ledger view for slot " <> showT (unSlotNo slotNo) + forHuman (TraceForgeStateUpdateError slotNo reason) = + "Updating the forge state in slot " + <> showT (unSlotNo slotNo) + <> " failed because: " + <> showT reason + forHuman (TraceNodeCannotForge slotNo reason) = + "We are the leader in slot " + <> showT (unSlotNo slotNo) + <> ", but we cannot forge because: " + <> showT reason + forHuman (TraceNodeNotLeader slotNo) = + "Not leading slot " <> showT (unSlotNo slotNo) + forHuman (TraceNodeIsLeader slotNo) = + "Leading slot " <> showT (unSlotNo slotNo) + forHuman (TraceForgeTickedLedgerState slotNo prevPt) = + "While forging in slot " + <> showT (unSlotNo slotNo) + <> " we ticked the ledger state ahead from " + <> renderPointAsPhrase prevPt + forHuman (TraceForgingMempoolSnapshot slotNo prevPt mpHash mpSlot) = + "While forging in slot " + <> showT (unSlotNo slotNo) + <> " we acquired a mempool snapshot valid against " + <> renderPointAsPhrase prevPt + <> " from a mempool that was prepared for " + <> renderChainHash @blk (renderHeaderHash (Proxy @blk)) mpHash + <> " ticked to slot " + <> showT (unSlotNo mpSlot) + forHuman (TraceForgedBlock slotNo _ _ _ _) = + "Forged block in slot " <> showT (unSlotNo slotNo) + forHuman (TraceDidntAdoptBlock slotNo _) = + "Didn't adopt forged block in slot " <> showT (unSlotNo slotNo) + forHuman (TraceForgedInvalidBlock slotNo _ reason) = + "Forged invalid block in slot " + <> showT (unSlotNo slotNo) + <> ", reason: " + <> showT reason + forHuman (TraceAdoptedBlock slotNo blk _txs) = + "Adopted block forged in slot " + <> showT (unSlotNo slotNo) + <> ": " + <> renderHeaderHash (Proxy @blk) (blockHash blk) + forHuman (TraceAdoptionThreadDied slotNo blk) = + "Adoption thread died in slot " + <> showT (unSlotNo slotNo) + <> ": " + <> renderHeaderHash (Proxy @blk) (blockHash blk) + + asMetrics (TraceForgeStateUpdateError slot reason) = + IntM "Forge.StateUpdateError" (fromIntegral $ unSlotNo slot) + : ( case getKESInfo (Proxy @blk) reason of + Nothing -> [] + Just kesInfo -> + [ IntM + "operationalCertificateStartKESPeriod" + (fromIntegral . unKESPeriod . HotKey.kesStartPeriod $ kesInfo) + , IntM + "operationalCertificateExpiryKESPeriod" + (fromIntegral . unKESPeriod . HotKey.kesEndPeriod $ kesInfo) + , IntM + "currentKESPeriod" + 0 + , IntM + "remainingKESPeriods" + 0 + ] + ) + asMetrics (TraceStartLeadershipCheck _slot) = + [CounterM "Forge.about-to-lead" Nothing] + asMetrics (TraceSlotIsImmutable _slot _tipPoint _tipBlkNo) = + [CounterM "Forge.slot-is-immutable" Nothing] + asMetrics (TraceBlockFromFuture _slot _slotNo) = + [CounterM "Forge.block-from-future" Nothing] + asMetrics (TraceNoLedgerState _slot _) = + [CounterM "Forge.could-not-forge" Nothing] + asMetrics (TraceNoLedgerView _slot _) = + [CounterM "Forge.could-not-forge" Nothing] + asMetrics (TraceLedgerView _) = [] + asMetrics TraceBlockContext{} = [] + asMetrics (TraceLedgerState _ _) = [] + asMetrics (TraceNodeCannotForge _slot _reason) = + [CounterM "Forge.could-not-forge" Nothing] + asMetrics (TraceNodeNotLeader _slot) = + [CounterM "Forge.node-not-leader" Nothing] + asMetrics (TraceNodeIsLeader _slot) = + [CounterM "Forge.node-is-leader" Nothing] + asMetrics TraceForgeTickedLedgerState{} = [] + asMetrics TraceForgingMempoolSnapshot{} = [] + asMetrics (TraceForgedBlock slot _ _ _ _) = + [ IntM "forgedSlotLast" (fromIntegral $ unSlotNo slot) + , CounterM "Forge.forged" Nothing + ] + asMetrics (TraceDidntAdoptBlock _slot _) = + [CounterM "Forge.didnt-adopt" Nothing] + asMetrics (TraceForgedInvalidBlock _slot _ _) = + [CounterM "Forge.forged-invalid" Nothing] + asMetrics (TraceAdoptedBlock _slot _ _) = + [CounterM "Forge.adopted" Nothing] + asMetrics (TraceAdoptionThreadDied _slot _) = + [CounterM "Forge.adoption-thread-died" Nothing] + +instance MetaTrace (TraceForgeEvent blk) where + namespaceFor TraceStartLeadershipCheck{} = + Namespace [] ["StartLeadershipCheck"] + namespaceFor TraceSlotIsImmutable{} = + Namespace [] ["SlotIsImmutable"] + namespaceFor TraceBlockFromFuture{} = + Namespace [] ["BlockFromFuture"] + namespaceFor TraceBlockContext{} = + Namespace [] ["BlockContext"] + namespaceFor TraceNoLedgerState{} = + Namespace [] ["NoLedgerState"] + namespaceFor TraceLedgerState{} = + Namespace [] ["LedgerState"] + namespaceFor TraceNoLedgerView{} = + Namespace [] ["NoLedgerView"] + namespaceFor TraceLedgerView{} = + Namespace [] ["LedgerView"] + namespaceFor TraceForgeStateUpdateError{} = + Namespace [] ["ForgeStateUpdateError"] + namespaceFor TraceNodeCannotForge{} = + Namespace [] ["NodeCannotForge"] + namespaceFor TraceNodeNotLeader{} = + Namespace [] ["NodeNotLeader"] + namespaceFor TraceNodeIsLeader{} = + Namespace [] ["NodeIsLeader"] + namespaceFor TraceForgeTickedLedgerState{} = + Namespace [] ["ForgeTickedLedgerState"] + namespaceFor TraceForgingMempoolSnapshot{} = + Namespace [] ["ForgingMempoolSnapshot"] + namespaceFor TraceForgedBlock{} = + Namespace [] ["ForgedBlock"] + namespaceFor TraceDidntAdoptBlock{} = + Namespace [] ["DidntAdoptBlock"] + namespaceFor TraceForgedInvalidBlock{} = + Namespace [] ["ForgedInvalidBlock"] + namespaceFor TraceAdoptedBlock{} = + Namespace [] ["AdoptedBlock"] + namespaceFor TraceAdoptionThreadDied{} = + Namespace [] ["AdoptionThreadDied"] + + severityFor (Namespace _ ["StartLeadershipCheck"]) _ = Just Info + severityFor (Namespace _ ["SlotIsImmutable"]) _ = Just Error + severityFor (Namespace _ ["BlockFromFuture"]) _ = Just Error + severityFor (Namespace _ ["BlockContext"]) _ = Just Debug + severityFor (Namespace _ ["NoLedgerState"]) _ = Just Error + severityFor (Namespace _ ["LedgerState"]) _ = Just Debug + severityFor (Namespace _ ["NoLedgerView"]) _ = Just Error + severityFor (Namespace _ ["LedgerView"]) _ = Just Debug + severityFor (Namespace _ ["ForgeStateUpdateError"]) _ = Just Critical + severityFor (Namespace _ ["NodeCannotForge"]) _ = Just Error + severityFor (Namespace _ ["NodeNotLeader"]) _ = Just Info + severityFor (Namespace _ ["NodeIsLeader"]) _ = Just Info + severityFor (Namespace _ ["ForgeTickedLedgerState"]) _ = Just Debug + severityFor (Namespace _ ["ForgingMempoolSnapshot"]) _ = Just Debug + severityFor (Namespace _ ["ForgedBlock"]) _ = Just Info + severityFor (Namespace _ ["DidntAdoptBlock"]) _ = Just Error + severityFor (Namespace _ ["ForgedInvalidBlock"]) _ = Just Error + severityFor (Namespace _ ["AdoptedBlock"]) _ = Just Info + severityFor (Namespace _ ["AdoptionThreadDied"]) _ = Just Error + severityFor _ _ = Nothing + + privacyFor (Namespace _ ["ForgeStateUpdateError"]) _ = Just Confidential + privacyFor _ _ = Just Public + + metricsDocFor (Namespace _ ["StartLeadershipCheck"]) = + [("Forge.about-to-lead", "")] + metricsDocFor (Namespace _ ["SlotIsImmutable"]) = + [("Forge.slot-is-immutable", "")] + metricsDocFor (Namespace _ ["BlockFromFuture"]) = + [("Forge.block-from-future", "")] + metricsDocFor (Namespace _ ["BlockContext"]) = [] + metricsDocFor (Namespace _ ["NoLedgerState"]) = + [("Forge.could-not-forge", "")] + metricsDocFor (Namespace _ ["LedgerState"]) = [] + metricsDocFor (Namespace _ ["NoLedgerView"]) = + [("Forge.could-not-forge", "")] + metricsDocFor (Namespace _ ["LedgerView"]) = [] + metricsDocFor (Namespace _ ["ForgeStateUpdateError"]) = + [ ("operationalCertificateStartKESPeriod", "") + , ("operationalCertificateExpiryKESPeriod", "") + , ("currentKESPeriod", "") + , ("remainingKESPeriods", "") + ] + metricsDocFor (Namespace _ ["NodeCannotForge"]) = + [("Forge.could-not-forge", "")] + metricsDocFor (Namespace _ ["NodeNotLeader"]) = + [("Forge.node-not-leader", "")] + metricsDocFor (Namespace _ ["NodeIsLeader"]) = + [("Forge.node-is-leader", "")] + metricsDocFor (Namespace _ ["ForgeTickedLedgerState"]) = [] + metricsDocFor (Namespace _ ["ForgingMempoolSnapshot"]) = [] + metricsDocFor (Namespace _ ["ForgedBlock"]) = + [ ("forgedSlotLast", "Slot number of the last forged block") + , ("Forge.forged", "Counter of forged blocks") + ] + metricsDocFor (Namespace _ ["DidntAdoptBlock"]) = + [("Forge.didnt-adopt", "")] + metricsDocFor (Namespace _ ["ForgedInvalidBlock"]) = + [("Forge.forged-invalid", "")] + metricsDocFor (Namespace _ ["AdoptedBlock"]) = + [("Forge.adopted", "")] + metricsDocFor (Namespace _ ["AdoptionThreadDied"]) = + [("Forge.adoption-thread-died", "")] + metricsDocFor _ = [] + + documentFor (Namespace _ ["StartLeadershipCheck"]) = + Just + "Start of the leadership check." + documentFor (Namespace _ ["SlotIsImmutable"]) = + Just $ + mconcat + [ "Leadership check failed: the tip of the ImmutableDB inhabits the" + , " current slot" + , " " + , " This might happen in two cases." + , " " + , " 1. the clock moved backwards, on restart we ignored everything from the" + , " VolatileDB since it's all in the future, and now the tip of the" + , " ImmutableDB points to a block produced in the same slot we're trying" + , " to produce a block in" + , " " + , " 2. k = 0 and we already adopted a block from another leader of the same" + , " slot." + , " " + , " We record both the current slot number as well as the tip of the" + , " ImmutableDB." + , " " + , " See also " + ] + documentFor (Namespace _ ["BlockFromFuture"]) = + Just $ + mconcat + [ "Leadership check failed: the current chain contains a block from a slot" + , " /after/ the current slot" + , " " + , " This can only happen if the system is under heavy load." + , " " + , " We record both the current slot number as well as the slot number of the" + , " block at the tip of the chain." + , " " + , " See also " + ] + documentFor (Namespace _ ["BlockContext"]) = + Just $ + mconcat + [ "We found out to which block we are going to connect the block we are about" + , " to forge." + , " " + , " We record the current slot number, the block number of the block to" + , " connect to and its point." + , " " + , " Note that block number of the block we will try to forge is one more than" + , " the recorded block number." + ] + documentFor (Namespace _ ["NoLedgerState"]) = + Just $ + mconcat + [ "Leadership check failed: we were unable to get the ledger state for the" + , " point of the block we want to connect to" + , " " + , " This can happen if after choosing which block to connect to the node" + , " switched to a different fork. We expect this to happen only rather" + , " rarely, so this certainly merits a warning; if it happens a lot, that" + , " merits an investigation." + , " " + , " We record both the current slot number as well as the point of the block" + , " we attempt to connect the new block to (that we requested the ledger" + , " state for)." + ] + documentFor (Namespace _ ["LedgerState"]) = + Just $ + mconcat + [ "We obtained a ledger state for the point of the block we want to" + , " connect to" + , " " + , " We record both the current slot number as well as the point of the block" + , " we attempt to connect the new block to (that we requested the ledger" + , " state for)." + ] + documentFor (Namespace _ ["NoLedgerView"]) = + Just $ + mconcat + [ "Leadership check failed: we were unable to get the ledger view for the" + , " current slot number" + , " " + , " This will only happen if there are many missing blocks between the tip of" + , " our chain and the current slot." + , " " + , " We record also the failure returned by 'forecastFor'." + ] + documentFor (Namespace _ ["LedgerView"]) = + Just $ + mconcat + [ "We obtained a ledger view for the current slot number" + , " " + , " We record the current slot number." + ] + documentFor (Namespace _ ["ForgeStateUpdateError"]) = + Just $ + mconcat + [ "Updating the forge state failed." + , " " + , " For example, the KES key could not be evolved anymore." + , " " + , " We record the error returned by 'updateForgeState'." + ] + documentFor (Namespace _ ["NodeCannotForge"]) = + Just $ + mconcat + [ "We did the leadership check and concluded that we should lead and forge" + , " a block, but cannot." + , " " + , " This should only happen rarely and should be logged with warning severity." + , " " + , " Records why we cannot forge a block." + ] + documentFor (Namespace _ ["NodeNotLeader"]) = + Just $ + mconcat + [ "We did the leadership check and concluded we are not the leader" + , " " + , " We record the current slot number" + ] + documentFor (Namespace _ ["NodeIsLeader"]) = + Just $ + mconcat + [ "We did the leadership check and concluded we /are/ the leader" + , "\n" + , " The node will soon forge; it is about to read its transactions from the" + , " Mempool. This will be followed by ForgedBlock." + ] + documentFor (Namespace _ ["ForgeTickedLedgerState"]) = Just "" + documentFor (Namespace _ ["ForgingMempoolSnapshot"]) = Just "" + documentFor (Namespace _ ["ForgedBlock"]) = + Just $ + mconcat + [ "We forged a block." + , "\n" + , " We record the current slot number, the point of the predecessor, the block" + , " itself, and the total size of the mempool snapshot at the time we produced" + , " the block (which may be significantly larger than the block, due to" + , " maximum block size)" + , "\n" + , " This will be followed by one of three messages:" + , "\n" + , " * AdoptedBlock (normally)" + , "\n" + , " * DidntAdoptBlock (rarely)" + , "\n" + , " * ForgedInvalidBlock (hopefully never, this would indicate a bug)" + ] + documentFor (Namespace _ ["DidntAdoptBlock"]) = + Just $ + mconcat + [ "We did not adopt the block we produced, but the block was valid. We" + , " must have adopted a block that another leader of the same slot produced" + , " before we got the chance of adopting our own block. This is very rare," + , " this warrants a warning." + ] + documentFor (Namespace _ ["ForgedInvalidBlock"]) = + Just $ + mconcat + [ "We forged a block that is invalid according to the ledger in the" + , " ChainDB. This means there is an inconsistency between the mempool" + , " validation and the ledger validation. This is a serious error!" + ] + documentFor (Namespace _ ["AdoptedBlock"]) = + Just $ + mconcat + [ "We adopted the block we produced, we also trace the transactions" + , " that were adopted." + ] + documentFor (Namespace _ ["AdoptionThreadDied"]) = + Just $ + mconcat + ["Block adoption thread died"] + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["StartLeadershipCheck"] + , Namespace [] ["SlotIsImmutable"] + , Namespace [] ["BlockFromFuture"] + , Namespace [] ["BlockContext"] + , Namespace [] ["NoLedgerState"] + , Namespace [] ["LedgerState"] + , Namespace [] ["NoLedgerView"] + , Namespace [] ["LedgerView"] + , Namespace [] ["ForgeStateUpdateError"] + , Namespace [] ["NodeCannotForge"] + , Namespace [] ["NodeNotLeader"] + , Namespace [] ["NodeIsLeader"] + , Namespace [] ["ForgeTickedLedgerState"] + , Namespace [] ["ForgingMempoolSnapshot"] + , Namespace [] ["ForgedBlock"] + , Namespace [] ["DidntAdoptBlock"] + , Namespace [] ["ForgedInvalidBlock"] + , Namespace [] ["AdoptedBlock"] + , Namespace [] ["AdoptionThreadDied"] + ] + +-------------------------------------------------------------------------------- +-- BlockchainTimeEvent Tracer +-------------------------------------------------------------------------------- + +instance Show t => LogFormatting (TraceBlockchainTimeEvent t) where + forMachine _dtal (TraceStartTimeInTheFuture (SystemStart start) toWait) = + mconcat + [ "kind" .= String "TStartTimeInTheFuture" + , "systemStart" .= String (showT start) + , "toWait" .= String (showT toWait) + ] + forMachine _dtal (TraceCurrentSlotUnknown time _) = + mconcat + [ "kind" .= String "CurrentSlotUnknown" + , "time" .= String (showT time) + ] + forMachine _dtal (TraceSystemClockMovedBack prevTime newTime) = + mconcat + [ "kind" .= String "SystemClockMovedBack" + , "prevTime" .= String (showT prevTime) + , "newTime" .= String (showT newTime) + ] + forHuman (TraceStartTimeInTheFuture (SystemStart start) toWait) = + "Waiting " + <> (Text.pack . show) toWait + <> " until genesis start time at " + <> (Text.pack . show) start + forHuman (TraceCurrentSlotUnknown time _) = + "Too far from the chain tip to determine the current slot number for the time " + <> (Text.pack . show) time + forHuman (TraceSystemClockMovedBack prevTime newTime) = + "The system wall clock time moved backwards, but within our tolerance " + <> "threshold. Previous 'current' time: " + <> (Text.pack . show) prevTime + <> ". New 'current' time: " + <> (Text.pack . show) newTime + +instance MetaTrace (TraceBlockchainTimeEvent t) where + namespaceFor TraceStartTimeInTheFuture{} = Namespace [] ["StartTimeInTheFuture"] + namespaceFor TraceCurrentSlotUnknown{} = Namespace [] ["CurrentSlotUnknown"] + namespaceFor TraceSystemClockMovedBack{} = Namespace [] ["SystemClockMovedBack"] + + severityFor (Namespace _ ["StartTimeInTheFuture"]) _ = Just Warning + severityFor (Namespace _ ["CurrentSlotUnknown"]) _ = Just Warning + severityFor (Namespace _ ["SystemClockMovedBack"]) _ = Just Warning + severityFor _ _ = Nothing + + documentFor (Namespace _ ["StartTimeInTheFuture"]) = + Just $ + mconcat + [ "The start time of the blockchain time is in the future" + , "\n" + , " We have to block (for 'NominalDiffTime') until that time comes." + ] + documentFor (Namespace _ ["CurrentSlotUnknown"]) = + Just $ + mconcat + [ "Current slot is not yet known" + , "\n" + , " This happens when the tip of our current chain is so far in the past that" + , " we cannot translate the current wallclock to a slot number, typically" + , " during syncing. Until the current slot number is known, we cannot" + , " produce blocks. Seeing this message during syncing therefore is" + , " normal and to be expected." + , "\n" + , " We record the current time (the time we tried to translate to a 'SlotNo')" + , " as well as the 'PastHorizonException', which provides detail on the" + , " bounds between which we /can/ do conversions. The distance between the" + , " current time and the upper bound should rapidly decrease with consecutive" + , " 'CurrentSlotUnknown' messages during syncing." + ] + documentFor (Namespace _ ["SystemClockMovedBack"]) = + Just $ + mconcat + [ "The system clock moved back an acceptable time span, e.g., because of" + , " an NTP sync." + , "\n" + , " The system clock moved back such that the new current slot would be" + , " smaller than the previous one. If this is within the configured limit, we" + , " trace this warning but *do not change the current slot*. The current slot" + , " never decreases, but the current slot may stay the same longer than" + , " expected." + , "\n" + , " When the system clock moved back more than the configured limit, we shut" + , " down with a fatal exception." + ] + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["StartTimeInTheFuture"] + , Namespace [] ["CurrentSlotUnknown"] + , Namespace [] ["SystemClockMovedBack"] + ] + +-------------------------------------------------------------------------------- +-- Gsm Tracer +-------------------------------------------------------------------------------- + +instance + ( LogFormatting selection + , Show selection + ) => + LogFormatting (TraceGsmEvent selection) + where + forMachine dtal = + \case + GsmEventInitializedInCaughtUp -> + mconcat + [ "kind" .= String "GsmEventInitializedInCaughtUp" + ] + GsmEventInitializedInPreSyncing -> + mconcat + [ "kind" .= String "GsmEventInitializedInPreSyncing" + ] + GsmEventEnterCaughtUp i s -> + mconcat + [ "kind" .= String "GsmEventEnterCaughtUp" + , "peerNumber" .= i + , "currentSelection" .= forMachine dtal s + ] + GsmEventLeaveCaughtUp s a -> + mconcat + [ "kind" .= String "GsmEventLeaveCaughtUp" + , "currentSelection" .= forMachine dtal s + , "age" .= toJSON (show a) + ] + GsmEventPreSyncingToSyncing -> + mconcat + [ "kind" .= String "GsmEventPreSyncingToSyncing" + ] + GsmEventSyncingToPreSyncing -> + mconcat + [ "kind" .= String "GsmEventSyncingToPreSyncing" + ] + + forHuman = showT + + asMetrics = + \case + GsmEventEnterCaughtUp{} -> [caughtUp] + GsmEventLeaveCaughtUp{} -> [preSyncing] + GsmEventPreSyncingToSyncing{} -> [syncing] + GsmEventSyncingToPreSyncing{} -> [preSyncing] + GsmEventInitializedInCaughtUp{} -> [caughtUp] + GsmEventInitializedInPreSyncing{} -> [preSyncing] + where + preSyncing = IntM "GSM.state" 0 + syncing = IntM "GSM.state" 1 + caughtUp = IntM "GSM.state" 2 + +instance MetaTrace (TraceGsmEvent selection) where + namespaceFor = + \case + GsmEventInitializedInCaughtUp -> Namespace [] ["InitializedInCaughtUp"] + GsmEventInitializedInPreSyncing -> Namespace [] ["InitializedInPreSyncing"] + GsmEventEnterCaughtUp{} -> Namespace [] ["EnterCaughtUp"] + GsmEventLeaveCaughtUp{} -> Namespace [] ["LeaveCaughtUp"] + GsmEventPreSyncingToSyncing{} -> Namespace [] ["PreSyncingToSyncing"] + GsmEventSyncingToPreSyncing{} -> Namespace [] ["SyncingToPreSyncing"] + + severityFor ns _ = + case ns of + Namespace _ ["InitializedInCaughtUp"] -> Just Notice + Namespace _ ["InitializedInPreSyncing"] -> Just Notice + Namespace _ ["EnterCaughtUp"] -> Just Notice + Namespace _ ["LeaveCaughtUp"] -> Just Warning + Namespace _ ["PreSyncingToSyncing"] -> Just Notice + Namespace _ ["SyncingToPreSyncing"] -> Just Notice + Namespace _ _ -> Nothing + + documentFor = \case + Namespace _ ["InitializedInCaughtUp"] -> Just "The GSM was initialized in the 'CaughtUp' state" + Namespace _ ["InitializedInPreSyncing"] -> Just "The GSM was initialized in the 'PreSyncing' state" + Namespace _ ["EnterCaughtUp"] -> + Just "Node is caught up" + Namespace _ ["LeaveCaughtUp"] -> + Just "Node is not caught up" + Namespace _ ["PreSyncingToSyncing"] -> + Just "The Honest Availability Assumption is now satisfied" + Namespace _ ["SyncingToPreSyncing"] -> + Just "The Honest Availability Assumption is no longer satisfied" + Namespace _ _ -> + Nothing + + metricsDocFor = \case + Namespace _ ["InitializedInCaughtUp"] -> doc + Namespace _ ["InitializedInPreSyncing"] -> doc + Namespace _ ["EnterCaughtUp"] -> doc + Namespace _ ["LeaveCaughtUp"] -> doc + Namespace _ ["PreSyncingToSyncing"] -> doc + Namespace _ ["SyncingToPreSyncing"] -> doc + Namespace _ _ -> [] + where + doc = + [ + ( "GSM.state" + , "The state of the Genesis State Machine. 0 = PreSyncing, 1 = Syncing, 2 = CaughtUp." + ) + ] + + allNamespaces = + [ Namespace [] ["InitializedInCaughtUp"] + , Namespace [] ["InitializedInPreSyncing"] + , Namespace [] ["EnterCaughtUp"] + , Namespace [] ["LeaveCaughtUp"] + , Namespace [] ["PreSyncingToSyncing"] + , Namespace [] ["SyncingToPreSyncing"] + ] + +-------------------------------------------------------------------------------- +-- CSJ Tracer +-------------------------------------------------------------------------------- + +instance + ( LogFormatting peer + , Show peer + , ConvertRawHash blk + ) => + LogFormatting (Jumping.TraceEventCsj peer blk) + where + forMachine dtal = \case + BecomingObjector prevObjector -> + mconcat + [ "kind" .= String "BecomingObjector" + , "previousObjector" .= (forMachine dtal <$> prevObjector) + ] + BlockedOnJump -> + mconcat + [ "kind" .= String "BlockedOnJump" + ] + InitializedAsDynamo -> + mconcat + [ "kind" .= String "InitializedAsDynamo" + ] + NoLongerDynamo newDynamo reason -> + mconcat + [ "kind" .= String "NoLongerDynamo" + , "newDynamo" .= (forMachine dtal <$> newDynamo) + , "reason" .= csjReasonToJSON reason + ] + NoLongerObjector newObjector reason -> + mconcat + [ "kind" .= String "NoLongerObjector" + , "newObjector" .= (forMachine dtal <$> newObjector) + , "reason" .= csjReasonToJSON reason + ] + SentJumpInstruction jumpTarget -> + mconcat + [ "kind" .= String "SentJumpInstruction" + , "jumpTarget" .= forMachine dtal jumpTarget + ] + where + csjReasonToJSON = \case + BecauseCsjDisengage -> String "BecauseCsjDisengage" + BecauseCsjDisconnect -> String "BecauseCsjDisconnect" + +instance MetaTrace (Jumping.TraceEventCsj peer blk) where + namespaceFor = \case + BecomingObjector{} -> Namespace [] ["BecomingObjector"] + BlockedOnJump{} -> Namespace [] ["BlockedOnJump"] + InitializedAsDynamo{} -> Namespace [] ["InitializedAsDynamo"] + NoLongerDynamo{} -> Namespace [] ["NoLongerDynamo"] + NoLongerObjector{} -> Namespace [] ["NoLongerObjector"] + SentJumpInstruction{} -> Namespace [] ["SentJumpInstruction"] + + severityFor ns _ = case ns of + Namespace _ ["BecomingObjector"] -> Just Debug + Namespace _ ["BlockedOnJump"] -> Just Debug + Namespace _ ["InitializedAsDynamo"] -> Just Debug + Namespace _ ["NoLongerDynamo"] -> Just Debug + Namespace _ ["NoLongerObjector"] -> Just Debug + Namespace _ ["SentJumpInstruction"] -> Just Debug + Namespace _ _ -> Nothing + + documentFor = \case + Namespace _ ["BecomingObjector"] -> Just "This peer is becoming the CSJ objector" + Namespace _ ["BlockedOnJump"] -> Just "This peer is blocked on a CSJ jump" + Namespace _ ["InitializedAsDynamo"] -> Just "This peer has been initialized as the CSJ dynamo" + Namespace _ ["NoLongerDynamo"] -> Just "This peer no longer is the CSJ dynamo" + Namespace _ ["NoLongerObjector"] -> Just "This peer no longer is the CSJ objector" + Namespace _ ["SentJumpInstruction"] -> Just "This peer has been instructed to jump via CSJ" + Namespace _ _ -> Nothing + + allNamespaces = + [ Namespace [] ["BecomingObjector"] + , Namespace [] ["BlockedOnJump"] + , Namespace [] ["InitializedAsDynamo"] + , Namespace [] ["NoLongerDynamo"] + , Namespace [] ["NoLongerObjector"] + , Namespace [] ["SentJumpInstruction"] + ] + +-------------------------------------------------------------------------------- +-- Devoted BlockFetch Tracer +-------------------------------------------------------------------------------- + +instance + ( LogFormatting peer + , Show peer + ) => + LogFormatting (Jumping.TraceEventDbf peer) + where + forMachine dtal = + \case + RotatedDynamo oldPeer newPeer -> + mconcat + [ "kind" .= String "RotatedDynamo" + , "oldPeer" .= forMachine dtal oldPeer + , "newPeer" .= forMachine dtal newPeer + ] + + forHuman (RotatedDynamo fromPeer toPeer) = + "Rotated the dynamo from " <> showT fromPeer <> " to " <> showT toPeer + +instance MetaTrace (Jumping.TraceEventDbf peer) where + namespaceFor = + \case + RotatedDynamo{} -> Namespace [] ["RotatedDynamo"] + + severityFor ns _ = + case ns of + Namespace _ ["RotatedDynamo"] -> Just Info + Namespace _ _ -> Nothing + + documentFor = \case + Namespace _ ["RotatedDynamo"] -> + Just "The ChainSync Jumping module has been asked to rotate its dynamo" + Namespace _ _ -> + Nothing + + allNamespaces = + [ Namespace [] ["RotatedDynamo"] + ] + +-------------------------------------------------------------------------------- +-- Chain tip tracer +-------------------------------------------------------------------------------- + +instance + ( StandardHash blk + , ConvertRawHash blk + ) => + LogFormatting (Tip blk) + where + forMachine _dtal TipGenesis = + mconcat ["kind" .= String "TipGenesis"] + forMachine _dtal (Tip slotNo hash bNo) = + mconcat + [ "kind" .= String "Tip" + , "tipSlotNo" .= toJSON (unSlotNo slotNo) + , "tipHash" .= renderHeaderHash (Proxy @blk) hash + , "tipBlockNo" .= toJSON bNo + ] + + forHuman = showT + +{------------------------------------------------------------------------------- + KES-agent +-------------------------------------------------------------------------------} + +-------------------------------------------------------------------------------- +-- KES Agent tracer +-------------------------------------------------------------------------------- + +instance LogFormatting Agent.ServiceClientTrace where + forMachine _dtal = \case + Agent.ServiceClientVersionHandshakeTrace _vhdt -> + mconcat ["kind" .= String "ServiceClientVersionHandshakeTrace"] + Agent.ServiceClientVersionHandshakeFailed -> + mconcat ["kind" .= String "ServiceClientVersionHandshakeFailed"] + Agent.ServiceClientDriverTrace _sdt -> + mconcat ["kind" .= String "ServiceClientDriverTrace"] + Agent.ServiceClientSocketClosed -> + mconcat ["kind" .= String "ServiceClientSocketClosed"] + Agent.ServiceClientConnected _s -> + mconcat ["kind" .= String "ServiceClientConnected"] + Agent.ServiceClientAttemptReconnect{} -> + mconcat ["kind" .= String "ServiceClientAttemptReconnect"] + Agent.ServiceClientReceivedKey _tbt -> + mconcat ["kind" .= String "ServiceClientReceivedKey"] + Agent.ServiceClientDeclinedKey _tbt -> + mconcat ["kind" .= String "ServiceClientDeclinedKey"] + Agent.ServiceClientDroppedKey -> + mconcat ["kind" .= String "ServiceClientDroppedKey"] + Agent.ServiceClientOpCertNumberCheck _ _ -> + mconcat ["kind" .= String "ServiceClientOpCertNumberCheck"] + Agent.ServiceClientAbnormalTermination _s -> + mconcat ["kind" .= String "ServiceClientAbnormalTermination"] + Agent.ServiceClientStopped -> + mconcat ["kind" .= String "ServiceClientStopped"] + + forHuman = showT + +instance MetaTrace Agent.ServiceClientTrace where + namespaceFor = \case + Agent.ServiceClientVersionHandshakeTrace _vhdt -> + Namespace [] ["ServiceClientVersionHandshakeTrace"] + Agent.ServiceClientVersionHandshakeFailed -> + Namespace [] ["ServiceClientVersionHandshakeFailed"] + Agent.ServiceClientDriverTrace _sdt -> + Namespace [] ["ServiceClientDriverTrace"] + Agent.ServiceClientSocketClosed -> + Namespace [] ["ServiceClientSocketClosed"] + Agent.ServiceClientConnected _s -> + Namespace [] ["ServiceClientConnected"] + Agent.ServiceClientAttemptReconnect{} -> + Namespace [] ["ServiceClientAttemptReconnect"] + Agent.ServiceClientReceivedKey _tbt -> + Namespace [] ["ServiceClientReceivedKey"] + Agent.ServiceClientDeclinedKey _tbt -> + Namespace [] ["ServiceClientDeclinedKey"] + Agent.ServiceClientDroppedKey -> + Namespace [] ["ServiceClientDroppedKey"] + Agent.ServiceClientOpCertNumberCheck _ _ -> + Namespace [] ["ServiceClientOpCertNumberCheck"] + Agent.ServiceClientAbnormalTermination _s -> + Namespace [] ["ServiceClientAbnormalTermination"] + Agent.ServiceClientStopped -> + Namespace [] ["ServiceClientStopped"] + + severityFor ns _ = case ns of + Namespace [] ["ServiceClientVersionHandshakeTrace"] -> + Just Debug + Namespace [] ["ServiceClientVersionHandshakeFailed"] -> + Just Error + Namespace [] ["ServiceClientDriverTrace"] -> + Just Debug + Namespace [] ["ServiceClientSocketClosed"] -> + Just Info + Namespace [] ["ServiceClientConnected"] -> + Just Info + Namespace [] ["ServiceClientAttemptReconnect"] -> + Just Info + Namespace [] ["ServiceClientReceivedKey"] -> + Just Info + Namespace [] ["ServiceClientDeclinedKey"] -> + Just Info + Namespace [] ["ServiceClientDroppedKey"] -> + Just Info + Namespace [] ["ServiceClientOpCertNumberCheck"] -> + Just Debug + Namespace [] ["ServiceClientAbnormalTermination"] -> + Just Error + Namespace [] ["ServiceClientStopped"] -> + Just Info + Namespace _ _ -> Nothing + + documentFor _ = Nothing + allNamespaces = + [ Namespace [] ["ServiceClientVersionHandshakeTrace"] + , Namespace [] ["ServiceClientVersionHandshakeFailed"] + , Namespace [] ["ServiceClientDriverTrace"] + , Namespace [] ["ServiceClientSocketClosed"] + , Namespace [] ["ServiceClientConnected"] + , Namespace [] ["ServiceClientAttemptReconnect"] + , Namespace [] ["ServiceClientReceivedKey"] + , Namespace [] ["ServiceClientDeclinedKey"] + , Namespace [] ["ServiceClientDroppedKey"] + , Namespace [] ["ServiceClientOpCertNumberCheck"] + , Namespace [] ["ServiceClientAbnormalTermination"] + , Namespace [] ["ServiceClientStopped"] + ] + +instance LogFormatting KESAgentClientTrace where + forMachine dtal = \case + KESAgentClientException ex -> + mconcat + [ "kind" .= String "KESAgentClientException" + , "exception" .= String (Text.pack $ show ex) + ] + KESAgentClientTrace t -> + mconcat + [ "kind" .= String "KESAgentClientTrace" + , "trace" .= forMachine dtal t + ] + + forHuman = showT + +instance MetaTrace KESAgentClientTrace where + namespaceFor = \case + KESAgentClientException _ -> + Namespace [] ["KESAgentClientException"] + KESAgentClientTrace t -> nsCast $ namespaceFor t + + severityFor (Namespace [] ["KESAgentClientException"]) _ = Just Error + severityFor ns (Just (KESAgentClientTrace t)) = severityFor (nsCast ns) (Just t) + severityFor ns Nothing = + severityFor (nsCast ns :: Namespace Agent.ServiceClientTrace) Nothing + severityFor _ _ = Nothing + + documentFor _ = Nothing + + allNamespaces = + Namespace [] ["KESAgentClientException"] + : fmap nsCast (allNamespaces :: [Namespace Agent.ServiceClientTrace]) + +-------------------------------------------------------------------------------- +-- Peras +-------------------------------------------------------------------------------- + +-- TODO: Move this to a proper place. A lot of this is duplicated in the +-- ToObject instance. This is likely in an incorrect place. Fix +-- duplication. + +-- | Object diffusion is instantiated once per diffused object kind: Peras +-- certificates and Peras votes. EKG metric names don't carry the tracer +-- namespace, so each kind supplies its own prefix; sharing one would make +-- cert and vote metrics overwrite each other. +-- +-- The two kinds share the same 'TraceObjectDiffusionInbound' \/ +-- 'TraceObjectDiffusionOutbound' type and are told apart by their object-id +-- type, which is what the instances below match on. The object type itself is +-- a type family ('PerasCert' \/ 'PerasVote') and so cannot appear in an +-- instance head; it is left free. A further diffusion kind adds its own pair +-- of instances for its own object-id type. +perasCertMetricsPrefix, perasVoteMetricsPrefix :: Text.Text +perasCertMetricsPrefix = "perasCert" +perasVoteMetricsPrefix = "perasVote" + +forMachineObjectDiffusionInbound :: + TraceObjectDiffusionInbound objectId object -> + Aeson.Object +forMachineObjectDiffusionInbound = \case + TraceObjectDiffusionInboundCollectedObjects payload -> + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundCollectedObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + TraceObjectDiffusionInboundAddedObjects payload -> + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundAddedObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + TraceObjectDiffusionInboundRecvControlMessage payload -> + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundRecvControlMessage" + , "payload" .= String (Text.pack . show $ payload) + ] + TraceObjectDiffusionInboundCanRequestMoreObjects payload -> + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundCanRequestMoreObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + TraceObjectDiffusionInboundCannotRequestMoreObjects payload -> + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundCannotRequestMoreObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + +asMetricsObjectDiffusionInbound :: + Text.Text -> + TraceObjectDiffusionInbound objectId object -> + [Metric] +asMetricsObjectDiffusionInbound prefix = \case + TraceObjectDiffusionInboundCollectedObjects collected -> + [IntM (prefix <> "ObjectsCollected") (fromIntegral collected)] + TraceObjectDiffusionInboundAddedObjects (NumObjectsProcessed added) -> + [CounterM (prefix <> "ObjectsAdded") (Just (fromIntegral added))] + _ -> [] + +metricsDocForObjectDiffusionInbound :: + Text.Text -> + Namespace a -> + [(Text.Text, Text.Text)] +metricsDocForObjectDiffusionInbound prefix = \case + Namespace _ ["TraceObjectDiffusionInboundCollectedObjects"] -> + [ + ( prefix <> "ObjectsCollected" + , "number of objects about to be inserted into the pool" + ) + ] + Namespace _ ["TraceObjectDiffusionInboundAddedObjects"] -> + [ + ( prefix <> "ObjectsAdded" + , "total number of objects accepted into the pool" + ) + ] + _ -> [] + +namespaceForObjectDiffusionInbound :: + TraceObjectDiffusionInbound objectId object -> + Namespace a +namespaceForObjectDiffusionInbound = \case + TraceObjectDiffusionInboundCollectedObjects _ -> + Namespace [] ["TraceObjectDiffusionInboundCollectedObjects"] + TraceObjectDiffusionInboundAddedObjects _ -> + Namespace [] ["TraceObjectDiffusionInboundAddedObjects"] + TraceObjectDiffusionInboundRecvControlMessage _ -> + Namespace [] ["TraceObjectDiffusionInboundRecvControlMessage"] + TraceObjectDiffusionInboundCanRequestMoreObjects _ -> + Namespace [] ["TraceObjectDiffusionInboundCanRequestMoreObjects"] + TraceObjectDiffusionInboundCannotRequestMoreObjects _ -> + Namespace [] ["TraceObjectDiffusionInboundCannotRequestMoreObjects"] + +documentForObjectDiffusionInbound :: Namespace a -> Maybe Text.Text +documentForObjectDiffusionInbound = \case + Namespace _ ["TraceObjectDiffusionInboundCollectedObjects"] -> + Just + "The number of objects received from the peer that are about to be inserted\ + \ into the object pool." + Namespace _ ["TraceObjectDiffusionInboundAddedObjects"] -> + Just + "The pass/fail breakdown of the objects just handed to the object pool." + Namespace _ ["TraceObjectDiffusionInboundRecvControlMessage"] -> + Just + "A control message was received from the outbound peer governor, and is\ + \ about to be acted on." + Namespace _ ["TraceObjectDiffusionInboundCanRequestMoreObjects"] -> + Just + "There is room to request more objects from the peer; the payload is how\ + \ many." + Namespace _ ["TraceObjectDiffusionInboundCannotRequestMoreObjects"] -> + Just + "No more objects can be requested from the peer for now; the payload is how\ + \ many are already in flight." + _ -> Nothing + +severityForObjectDiffusionInbound :: Namespace a -> Maybe SeverityS +severityForObjectDiffusionInbound = \case + Namespace _ ["TraceObjectDiffusionInboundCollectedObjects"] -> Just Info + Namespace _ ["TraceObjectDiffusionInboundAddedObjects"] -> Just Info + Namespace _ ["TraceObjectDiffusionInboundRecvControlMessage"] -> Just Info + Namespace _ ["TraceObjectDiffusionInboundCanRequestMoreObjects"] -> Just Info + Namespace _ ["TraceObjectDiffusionInboundCannotRequestMoreObjects"] -> Just Info + _ -> Nothing + +allNamespacesObjectDiffusionInbound :: [Namespace a] +allNamespacesObjectDiffusionInbound = + [ Namespace [] ["TraceObjectDiffusionInboundCollectedObjects"] + , Namespace [] ["TraceObjectDiffusionInboundAddedObjects"] + , Namespace [] ["TraceObjectDiffusionInboundRecvControlMessage"] + , Namespace [] ["TraceObjectDiffusionInboundCanRequestMoreObjects"] + , Namespace [] ["TraceObjectDiffusionInboundCannotRequestMoreObjects"] + ] + +-- | Peras certificate diffusion, inbound side. +instance LogFormatting (TraceObjectDiffusionInbound PerasRoundNo object) where + forMachine _ = forMachineObjectDiffusionInbound + asMetrics = asMetricsObjectDiffusionInbound perasCertMetricsPrefix + +instance MetaTrace (TraceObjectDiffusionInbound PerasRoundNo object) where + namespaceFor = namespaceForObjectDiffusionInbound + severityFor ns _ = severityForObjectDiffusionInbound ns + documentFor = documentForObjectDiffusionInbound + metricsDocFor = metricsDocForObjectDiffusionInbound perasCertMetricsPrefix + allNamespaces = allNamespacesObjectDiffusionInbound + +-- | Peras vote diffusion, inbound side. +instance LogFormatting (TraceObjectDiffusionInbound PerasVoteId object) where + forMachine _ = forMachineObjectDiffusionInbound + asMetrics = asMetricsObjectDiffusionInbound perasVoteMetricsPrefix + +instance MetaTrace (TraceObjectDiffusionInbound PerasVoteId object) where + namespaceFor = namespaceForObjectDiffusionInbound + severityFor ns _ = severityForObjectDiffusionInbound ns + documentFor = documentForObjectDiffusionInbound + metricsDocFor = metricsDocForObjectDiffusionInbound perasVoteMetricsPrefix + allNamespaces = allNamespacesObjectDiffusionInbound + +forMachineObjectDiffusionOutbound :: + ( Show objectId + , Show object + ) => + TraceObjectDiffusionOutbound objectId object -> + Aeson.Object +forMachineObjectDiffusionOutbound = \case + TraceObjectDiffusionOutboundRecvMsgRequestObjectIds payload -> + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundRecvMsgRequestObjectIds" + , "payload" .= String (Text.pack . show $ payload) + ] + TraceObjectDiffusionOutboundSendMsgReplyObjectIds payload -> + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundSendMsgReplyObjectIds" + , "payload" .= String (Text.pack . show $ payload) + ] + TraceObjectDiffusionOutboundRecvMsgRequestObjects payload -> + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundRecvMsgRequestObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + TraceObjectDiffusionOutboundSendMsgReplyObjects payload -> + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundSendMsgReplyObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + TraceObjectDiffusionOutboundTerminated -> + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundTerminated" + ] + +asMetricsObjectDiffusionOutbound :: + Text.Text -> + TraceObjectDiffusionOutbound objectId object -> + [Metric] +asMetricsObjectDiffusionOutbound prefix = \case + TraceObjectDiffusionOutboundSendMsgReplyObjects objects -> + [CounterM (prefix <> "ObjectsSent") (Just (length objects))] + _ -> [] + +metricsDocForObjectDiffusionOutbound :: + Text.Text -> + Namespace a -> + [(Text.Text, Text.Text)] +metricsDocForObjectDiffusionOutbound prefix = \case + Namespace _ ["TraceObjectDiffusionOutboundSendMsgReplyObjects"] -> + [ + ( prefix <> "ObjectsSent" + , "total number of objects served to peers" + ) + ] + _ -> [] + +namespaceForObjectDiffusionOutbound :: + TraceObjectDiffusionOutbound objectId object -> + Namespace a +namespaceForObjectDiffusionOutbound = \case + TraceObjectDiffusionOutboundRecvMsgRequestObjectIds _ -> + Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjectIds"] + TraceObjectDiffusionOutboundSendMsgReplyObjectIds _ -> + Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjectIds"] + TraceObjectDiffusionOutboundRecvMsgRequestObjects _ -> + Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjects"] + TraceObjectDiffusionOutboundSendMsgReplyObjects _ -> + Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjects"] + TraceObjectDiffusionOutboundTerminated -> + Namespace [] ["TraceObjectDiffusionOutboundTerminated"] + +documentForObjectDiffusionOutbound :: Namespace a -> Maybe Text.Text +documentForObjectDiffusionOutbound = \case + Namespace _ ["TraceObjectDiffusionOutboundRecvMsgRequestObjectIds"] -> + Just + "The peer asked for object ids; the payload is how many it asked for." + Namespace _ ["TraceObjectDiffusionOutboundSendMsgReplyObjectIds"] -> + Just + "The object ids about to be sent to the peer in reply." + Namespace _ ["TraceObjectDiffusionOutboundRecvMsgRequestObjects"] -> + Just + "The peer asked for the objects with these ids." + Namespace _ ["TraceObjectDiffusionOutboundSendMsgReplyObjects"] -> + Just + "The objects about to be sent to the peer in reply." + Namespace _ ["TraceObjectDiffusionOutboundTerminated"] -> + Just + "The peer sent MsgDone, ending the object diffusion session." + _ -> Nothing + +severityForObjectDiffusionOutbound :: Namespace a -> Maybe SeverityS +severityForObjectDiffusionOutbound = \case + Namespace _ ["TraceObjectDiffusionOutboundRecvMsgRequestObjectIds"] -> Just Info + Namespace _ ["TraceObjectDiffusionOutboundSendMsgReplyObjectIds"] -> Just Info + Namespace _ ["TraceObjectDiffusionOutboundRecvMsgRequestObjects"] -> Just Info + Namespace _ ["TraceObjectDiffusionOutboundSendMsgReplyObjects"] -> Just Info + Namespace _ ["TraceObjectDiffusionOutboundTerminated"] -> Just Info + _ -> Nothing + +allNamespacesObjectDiffusionOutbound :: [Namespace a] +allNamespacesObjectDiffusionOutbound = + [ Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjectIds"] + , Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjectIds"] + , Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjects"] + , Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjects"] + , Namespace [] ["TraceObjectDiffusionOutboundTerminated"] + ] + +-- | Peras certificate diffusion, outbound side. +instance + Show object => + LogFormatting (TraceObjectDiffusionOutbound PerasRoundNo object) + where + forMachine _ = forMachineObjectDiffusionOutbound + asMetrics = asMetricsObjectDiffusionOutbound perasCertMetricsPrefix + +instance MetaTrace (TraceObjectDiffusionOutbound PerasRoundNo object) where + namespaceFor = namespaceForObjectDiffusionOutbound + severityFor ns _ = severityForObjectDiffusionOutbound ns + documentFor = documentForObjectDiffusionOutbound + metricsDocFor = metricsDocForObjectDiffusionOutbound perasCertMetricsPrefix + allNamespaces = allNamespacesObjectDiffusionOutbound + +-- | Peras vote diffusion, outbound side. +instance + Show object => + LogFormatting (TraceObjectDiffusionOutbound PerasVoteId object) + where + forMachine _ = forMachineObjectDiffusionOutbound + asMetrics = asMetricsObjectDiffusionOutbound perasVoteMetricsPrefix + +instance MetaTrace (TraceObjectDiffusionOutbound PerasVoteId object) where + namespaceFor = namespaceForObjectDiffusionOutbound + severityFor ns _ = severityForObjectDiffusionOutbound ns + documentFor = documentForObjectDiffusionOutbound + metricsDocFor = metricsDocForObjectDiffusionOutbound perasVoteMetricsPrefix + allNamespaces = allNamespacesObjectDiffusionOutbound + +-------------------------------------------------------------------------------- +-- Peras cert inclusion Tracer +-------------------------------------------------------------------------------- + +instance + Show (PerasCert blk) => + LogFormatting (TracePerasCertInclusionEvent blk) + where + forMachine _dtal = \case + TracePerasCertInclusionNoCertToInclude slotNo -> + mconcat + [ "kind" .= String "TracePerasCertInclusionNoCertToInclude" + , "slot" .= unSlotNo slotNo + ] + TracePerasCertInclusionRulesDecision slotNo roundNo decision -> + mconcat + [ "kind" .= String "TracePerasCertInclusionRulesDecision" + , "slot" .= unSlotNo slotNo + , "round" .= unPerasRoundNo roundNo + , "decision" .= String (showT decision) + ] + + forHuman = \case + TracePerasCertInclusionNoCertToInclude slotNo -> + "No Peras certificate available to include in slot " + <> showT (unSlotNo slotNo) + TracePerasCertInclusionRulesDecision slotNo roundNo decision -> + "Peras certificate inclusion rules decided " + <> showT decision + <> " in slot " + <> showT (unSlotNo slotNo) + <> ", round " + <> showT (unPerasRoundNo roundNo) + +instance MetaTrace (TracePerasCertInclusionEvent blk) where + namespaceFor TracePerasCertInclusionNoCertToInclude{} = + Namespace [] ["NoCertToInclude"] + namespaceFor TracePerasCertInclusionRulesDecision{} = + Namespace [] ["RulesDecision"] + + severityFor (Namespace _ ["NoCertToInclude"]) _ = Just Debug + severityFor (Namespace _ ["RulesDecision"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["NoCertToInclude"]) = + Just + "There is no Peras certificate available to include in the block being forged." + documentFor (Namespace _ ["RulesDecision"]) = + Just + "The decision taken by the Peras certificate inclusion rules, i.e. whether a\ + \ certificate is to be included in the block being forged, and why." + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["NoCertToInclude"] + , Namespace [] ["RulesDecision"] + ] + +-------------------------------------------------------------------------------- +-- Peras vote forging Tracer +-------------------------------------------------------------------------------- + +instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + LogFormatting (TracePerasVoteForgingEvent blk) + where + forMachine _dtal = \case + TracePerasVotingNoVoteAfterFirstSlotInRound roundNo slotInRound -> + mconcat + [ "kind" .= String "TracePerasVotingNoVoteAfterFirstSlotInRound" + , "round" .= unPerasRoundNo roundNo + , "slotInRound" .= slotInRound + ] + TracePerasVotingNotAVoterInRound roundNo -> + mconcat + [ "kind" .= String "TracePerasVotingNotAVoterInRound" + , "round" .= unPerasRoundNo roundNo + ] + TracePerasVotingRulesDecision roundNo decision -> + mconcat + [ "kind" .= String "TracePerasVotingRulesDecision" + , "round" .= unPerasRoundNo roundNo + , "decision" .= String (showT decision) + ] + TracePerasVotingForgedVote roundNo vote -> + mconcat + [ "kind" .= String "TracePerasVotingForgedVote" + , "round" .= unPerasRoundNo roundNo + , "vote" .= String (showT vote) + ] + TracePerasVotingAddVoteResult roundNo result -> + mconcat + [ "kind" .= String "TracePerasVotingAddVoteResult" + , "round" .= unPerasRoundNo roundNo + , "result" .= String (showT result) + ] + TracePerasVotingAddCertChainSelOutcome roundNo outcome -> + mconcat + [ "kind" .= String "TracePerasVotingAddCertChainSelOutcome" + , "round" .= unPerasRoundNo roundNo + , "outcome" .= String (showT outcome) + ] + TracePerasVotingCantReadEnv err -> + mconcat + [ "kind" .= String "TracePerasVotingCantReadEnv" + , "error" .= String (Text.pack err) + ] + + forHuman = \case + TracePerasVotingNoVoteAfterFirstSlotInRound roundNo slotInRound -> + "Not voting in Peras round " + <> showT (unPerasRoundNo roundNo) + <> ": past the first slot of the round (slot " + <> showT slotInRound + <> ")" + TracePerasVotingNotAVoterInRound roundNo -> + "Not a voter in Peras round " <> showT (unPerasRoundNo roundNo) + TracePerasVotingRulesDecision roundNo decision -> + "Peras voting rules decided " + <> showT decision + <> " in round " + <> showT (unPerasRoundNo roundNo) + TracePerasVotingForgedVote roundNo vote -> + "Forged Peras vote in round " + <> showT (unPerasRoundNo roundNo) + <> ": " + <> showT vote + TracePerasVotingAddVoteResult roundNo result -> + "Adding the Peras vote of round " + <> showT (unPerasRoundNo roundNo) + <> " to the vote DB: " + <> showT result + TracePerasVotingAddCertChainSelOutcome roundNo outcome -> + "Adding the Peras certificate of round " + <> showT (unPerasRoundNo roundNo) + <> " to the cert DB: " + <> showT outcome + TracePerasVotingCantReadEnv err -> + "Could not read the Peras voting environment: " <> Text.pack err + +instance MetaTrace (TracePerasVoteForgingEvent blk) where + namespaceFor TracePerasVotingNoVoteAfterFirstSlotInRound{} = + Namespace [] ["NoVoteAfterFirstSlotInRound"] + namespaceFor TracePerasVotingNotAVoterInRound{} = + Namespace [] ["NotAVoterInRound"] + namespaceFor TracePerasVotingRulesDecision{} = + Namespace [] ["RulesDecision"] + namespaceFor TracePerasVotingForgedVote{} = + Namespace [] ["ForgedVote"] + namespaceFor TracePerasVotingAddVoteResult{} = + Namespace [] ["AddVoteResult"] + namespaceFor TracePerasVotingAddCertChainSelOutcome{} = + Namespace [] ["AddCertChainSelOutcome"] + namespaceFor TracePerasVotingCantReadEnv{} = + Namespace [] ["CantReadEnv"] + + severityFor (Namespace _ ["NoVoteAfterFirstSlotInRound"]) _ = Just Debug + severityFor (Namespace _ ["NotAVoterInRound"]) _ = Just Debug + severityFor (Namespace _ ["RulesDecision"]) _ = Just Info + severityFor (Namespace _ ["ForgedVote"]) _ = Just Info + severityFor (Namespace _ ["AddVoteResult"]) _ = Just Info + severityFor (Namespace _ ["AddCertChainSelOutcome"]) _ = Just Info + severityFor (Namespace _ ["CantReadEnv"]) _ = Just Error + severityFor _ _ = Nothing + + documentFor (Namespace _ ["NoVoteAfterFirstSlotInRound"]) = + Just + "Votes are only cast in the first slot of a Peras round, and this slot is not it." + documentFor (Namespace _ ["NotAVoterInRound"]) = + Just + "This node was not elected to the voting committee of the current Peras round." + documentFor (Namespace _ ["RulesDecision"]) = + Just + "The decision taken by the Peras voting rules, i.e. whether a vote is to be\ + \ cast in the current round, and why." + documentFor (Namespace _ ["ForgedVote"]) = + Just + "A Peras vote was forged for the current round." + documentFor (Namespace _ ["AddVoteResult"]) = + Just + "The result of adding the freshly forged vote to the Peras vote DB, which is\ + \ where it may complete a quorum and yield a new certificate." + documentFor (Namespace _ ["AddCertChainSelOutcome"]) = + Just + "The outcome of handing a certificate generated by the freshly forged vote to\ + \ chain selection." + documentFor (Namespace _ ["CantReadEnv"]) = + Just + "The Peras voting environment could not be read." + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["NoVoteAfterFirstSlotInRound"] + , Namespace [] ["NotAVoterInRound"] + , Namespace [] ["RulesDecision"] + , Namespace [] ["ForgedVote"] + , Namespace [] ["AddVoteResult"] + , Namespace [] ["AddCertChainSelOutcome"] + , Namespace [] ["CantReadEnv"] + ] diff --git a/tracing/Ouroboros/Consensus/Tracing/ConsensusStartupException.hs b/tracing/Ouroboros/Consensus/Tracing/ConsensusStartupException.hs new file mode 100644 index 0000000000..ca03da2438 --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/ConsensusStartupException.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Consensus startup exception +module Ouroboros.Consensus.Tracing.ConsensusStartupException + ( ConsensusStartupException (..) + ) where + +import Cardano.Logging.Types +import Control.Exception (SomeException) +import Data.Aeson (Value (String), (.=)) +import qualified Data.Text as Text + +-- | Exceptions logged when the consensus is initialising. +newtype ConsensusStartupException = ConsensusStartupException SomeException + deriving Show + +instance LogFormatting ConsensusStartupException where + forMachine _ (ConsensusStartupException err) = + mconcat + [ "kind" .= String "ConsensusStartupException" + , "error" .= String (Text.pack . show $ err) + ] + forHuman = Text.pack . show + +instance MetaTrace ConsensusStartupException where + namespaceFor ConsensusStartupException{} = Namespace [] ["ConsensusStartupException"] + + severityFor (Namespace _ ["ConsensusStartupException"]) _ = Just Error + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ConsensusStartupException"]) = + Just + "An exception was thrown while the Consensus layer was starting up. The node\ + \ does not come up when this is traced." + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["ConsensusStartupException"]] diff --git a/tracing/Ouroboros/Consensus/Tracing/ConvertTxId.hs b/tracing/Ouroboros/Consensus/Tracing/ConvertTxId.hs new file mode 100644 index 0000000000..eb2f4b368b --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/ConvertTxId.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Projection of a transaction id to its raw bytes. +-- +-- Used by the tracing instances to render transaction ids, but it is a plain +-- projection over Consensus block types with no dependency on the logging +-- framework. +module Ouroboros.Consensus.Tracing.ConvertTxId + ( ConvertTxId (..) + ) where + +import qualified Cardano.Crypto.Hash as Crypto +import qualified Cardano.Crypto.Hashing as Byron.Crypto +import qualified Cardano.Ledger.Hashes as Ledger +import qualified Cardano.Ledger.TxIn as Ledger +import Data.ByteString (ByteString) +import Data.SOP +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) +import Ouroboros.Consensus.Byron.Ledger.Mempool (TxId (..)) +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock) +import Ouroboros.Consensus.Shelley.Ledger.Mempool (TxId (..)) +import Ouroboros.Consensus.TypeFamilyWrappers (unwrapGenTxId) + +-- | Convert a transaction ID to raw bytes. +class ConvertTxId blk where + txIdToRawBytes :: TxId (GenTx blk) -> ByteString + +instance ConvertTxId ByronBlock where + txIdToRawBytes (ByronTxId txId) = Byron.Crypto.abstractHashToBytes txId + txIdToRawBytes (ByronDlgId dlgId) = Byron.Crypto.abstractHashToBytes dlgId + txIdToRawBytes (ByronUpdateProposalId upId) = + Byron.Crypto.abstractHashToBytes upId + txIdToRawBytes (ByronUpdateVoteId voteId) = + Byron.Crypto.abstractHashToBytes voteId + +instance ConvertTxId (ShelleyBlock protocol c) where + txIdToRawBytes (ShelleyTxId txId) = + Crypto.hashToBytes . Ledger.extractHash . Ledger.unTxId $ txId + +instance + All ConvertTxId xs => + ConvertTxId (HardForkBlock xs) + where + txIdToRawBytes = + hcollapse + . hcmap (Proxy @ConvertTxId) (K . txIdToRawBytes . unwrapGenTxId) + . getOneEraGenTxId + . getHardForkGenTxId diff --git a/tracing/Ouroboros/Consensus/Tracing/Era/Byron.hs b/tracing/Ouroboros/Consensus/Tracing/Era/Byron.hs new file mode 100644 index 0000000000..98de368940 --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/Era/Byron.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ouroboros.Consensus.Tracing.Era.Byron () where + +import Cardano.Chain.Block + ( ABlockOrBoundaryHdr (..) + , AHeader (..) + , ChainValidationError (..) + , delegationCertificate + ) +import Cardano.Chain.Byron.API (ApplyMempoolPayloadErr (..)) +import qualified Cardano.Chain.Byron.API as CC +import Cardano.Chain.Delegation (delegateVK) +import Cardano.Crypto.Signing (VerificationKey) +import Cardano.Logging +import Data.Aeson (Value (String), (.=)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base16 as B16 +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import Ouroboros.Consensus.Block (Header) +import Ouroboros.Consensus.Block.EBB (fromIsEBB) +import Ouroboros.Consensus.Byron.Ledger + ( ByronBlock (..) + , ByronOtherHeaderEnvelopeError (..) + , byronHeaderRaw + , toMempoolPayload + ) +import Ouroboros.Consensus.Byron.Ledger.Inspect + ( ByronLedgerUpdate (..) + , ProtocolUpdate (..) + , UpdateState (..) + ) +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, txId) +import Ouroboros.Consensus.Protocol.PBFT (PBftTiebreakerView (..)) +import Ouroboros.Consensus.Tracing.Render (renderTxId) +import Ouroboros.Consensus.Util.Condense (condense) +import Ouroboros.Network.Block (blockHash, blockNo, blockSlot) + +textShow :: Show a => a -> Text +textShow = Text.pack . show + +-- + +-- | instances of @LogFormatting@ +-- +-- NOTE: this list is sorted by the unqualified name of the outermost type. +instance LogFormatting ApplyMempoolPayloadErr where + forMachine _dtal (MempoolTxErr utxoValidationErr) = + mconcat + [ "kind" .= String "MempoolTxErr" + , "error" .= String (textShow utxoValidationErr) + ] + forMachine _dtal (MempoolDlgErr delegScheduleError) = + mconcat + [ "kind" .= String "MempoolDlgErr" + , "error" .= String (textShow delegScheduleError) + ] + forMachine _dtal (MempoolUpdateProposalErr iFaceErr) = + mconcat + [ "kind" .= String "MempoolUpdateProposalErr" + , "error" .= String (textShow iFaceErr) + ] + forMachine _dtal (MempoolUpdateVoteErr iFaceErrr) = + mconcat + [ "kind" .= String "MempoolUpdateVoteErr" + , "error" .= String (textShow iFaceErrr) + ] + +instance LogFormatting ByronLedgerUpdate where + forMachine dtal (ByronUpdatedProtocolUpdates protocolUpdates) = + mconcat + [ "kind" .= String "ByronUpdatedProtocolUpdates" + , "protocolUpdates" .= map (forMachine dtal) protocolUpdates + ] + +instance LogFormatting ProtocolUpdate where + forMachine dtal (ProtocolUpdate updateVersion updateState) = + mconcat + [ "kind" .= String "ProtocolUpdate" + , "protocolUpdateVersion" .= updateVersion + , "protocolUpdateState" .= forMachine dtal updateState + ] + +instance LogFormatting UpdateState where + forMachine _dtal updateState = case updateState of + UpdateRegistered slot -> + mconcat + [ "kind" .= String "UpdateRegistered" + , "slot" .= slot + ] + UpdateActive votes -> + mconcat + [ "kind" .= String "UpdateActive" + , "votes" .= map (Text.pack . show) (Set.toList votes) + ] + UpdateConfirmed slot -> + mconcat + [ "kind" .= String "UpdateConfirmed" + , "slot" .= slot + ] + UpdateStablyConfirmed endorsements -> + mconcat + [ "kind" .= String "UpdateStablyConfirmed" + , "endorsements" .= map (Text.pack . show) (Set.toList endorsements) + ] + UpdateCandidate slot epoch -> + mconcat + [ "kind" .= String "UpdateCandidate" + , "slot" .= slot + , "epoch" .= epoch + ] + UpdateStableCandidate transitionEpoch -> + mconcat + [ "kind" .= String "UpdateStableCandidate" + , "transitionEpoch" .= transitionEpoch + ] + +instance LogFormatting (GenTx ByronBlock) where + forMachine dtal tx = + mconcat $ + ("txid" .= (Text.take 8 . renderTxId $ txId tx)) + -- We want to emit only the CBOR hex of the tx, not the decoded tx itself. + : [ "tx" + .= Text.Encoding.decodeLatin1 (B16.encode (CC.mempoolPayloadRecoverBytes (toMempoolPayload tx))) + | dtal == DDetailed + ] + +instance LogFormatting ChainValidationError where + forMachine _dtal ChainValidationBoundaryTooLarge = + mconcat + ["kind" .= String "ChainValidationBoundaryTooLarge"] + forMachine _dtal ChainValidationBlockAttributesTooLarge = + mconcat + ["kind" .= String "ChainValidationBlockAttributesTooLarge"] + forMachine _dtal (ChainValidationBlockTooLarge _ _) = + mconcat + ["kind" .= String "ChainValidationBlockTooLarge"] + forMachine _dtal ChainValidationHeaderAttributesTooLarge = + mconcat + ["kind" .= String "ChainValidationHeaderAttributesTooLarge"] + forMachine _dtal (ChainValidationHeaderTooLarge _ _) = + mconcat + ["kind" .= String "ChainValidationHeaderTooLarge"] + forMachine _dtal (ChainValidationDelegationPayloadError err) = + mconcat + ["kind" .= String err] + forMachine _dtal (ChainValidationInvalidDelegation _ _) = + mconcat + ["kind" .= String "ChainValidationInvalidDelegation"] + forMachine _dtal (ChainValidationGenesisHashMismatch _ _) = + mconcat + ["kind" .= String "ChainValidationGenesisHashMismatch"] + forMachine _dtal (ChainValidationExpectedGenesisHash _ _) = + mconcat + ["kind" .= String "ChainValidationExpectedGenesisHash"] + forMachine _dtal (ChainValidationExpectedHeaderHash _ _) = + mconcat + ["kind" .= String "ChainValidationExpectedHeaderHash"] + forMachine _dtal (ChainValidationInvalidHash _ _) = + mconcat + ["kind" .= String "ChainValidationInvalidHash"] + forMachine _dtal (ChainValidationMissingHash _) = + mconcat + ["kind" .= String "ChainValidationMissingHash"] + forMachine _dtal (ChainValidationUnexpectedGenesisHash _) = + mconcat + ["kind" .= String "ChainValidationUnexpectedGenesisHash"] + forMachine _dtal (ChainValidationInvalidSignature _) = + mconcat + ["kind" .= String "ChainValidationInvalidSignature"] + forMachine _dtal (ChainValidationDelegationSchedulingError _) = + mconcat + ["kind" .= String "ChainValidationDelegationSchedulingError"] + forMachine _dtal (ChainValidationProtocolMagicMismatch _ _) = + mconcat + ["kind" .= String "ChainValidationProtocolMagicMismatch"] + forMachine _dtal ChainValidationSignatureLight = + mconcat + ["kind" .= String "ChainValidationSignatureLight"] + forMachine _dtal (ChainValidationTooManyDelegations _) = + mconcat + ["kind" .= String "ChainValidationTooManyDelegations"] + forMachine _dtal (ChainValidationUpdateError _ _) = + mconcat + ["kind" .= String "ChainValidationUpdateError"] + forMachine _dtal (ChainValidationUTxOValidationError _) = + mconcat + ["kind" .= String "ChainValidationUTxOValidationError"] + forMachine _dtal (ChainValidationProofValidationError _) = + mconcat + ["kind" .= String "ChainValidationProofValidationError"] + +instance LogFormatting (Header ByronBlock) where + forMachine _dtal b = + mconcat $ + [ "kind" .= String "ByronBlock" + , "hash" .= condense (blockHash b) + , "slotNo" .= condense (blockSlot b) + , "blockNo" .= condense (blockNo b) + ] + <> case byronHeaderRaw b of + ABOBBoundaryHdr{} -> [] + ABOBBlockHdr h -> + ["delegate" .= condense (headerSignerVk h)] + where + headerSignerVk :: AHeader ByteString -> VerificationKey + headerSignerVk = + delegateVK . delegationCertificate . headerSignature + +instance LogFormatting ByronOtherHeaderEnvelopeError where + forMachine _dtal (UnexpectedEBBInSlot slot) = + mconcat + [ "kind" .= String "UnexpectedEBBInSlot" + , "slot" .= slot + ] + +instance LogFormatting PBftTiebreakerView where + forMachine _dtal (PBftTiebreakerView isEBB) = + mconcat + [ "kind" .= String "PBftSelectView" + , "isEBB" .= fromIsEBB isEBB + ] diff --git a/tracing/Ouroboros/Consensus/Tracing/Era/HardFork.hs b/tracing/Ouroboros/Consensus/Tracing/Era/HardFork.hs new file mode 100644 index 0000000000..e3ac255d18 --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/Era/HardFork.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ouroboros.Consensus.Tracing.Era.HardFork () +where + +import Cardano.Logging +import Cardano.Slotting.Slot (EpochSize (..)) +import Data.Aeson +import Data.Proxy (Proxy (..)) +import Data.SOP (All, Compose, K (K)) +import Data.SOP.Strict +import Ouroboros.Consensus.Block + ( BlockProtocol + , CannotForge + , ForgeStateInfo + , ForgeStateUpdateError + , PerasWeight (..) + ) +import Ouroboros.Consensus.BlockchainTime (getSlotLength) +import Ouroboros.Consensus.Cardano.Condense () +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras + ( EraMismatch (..) + , OneEraCannotForge (..) + , OneEraEnvelopeErr (..) + , OneEraForgeStateInfo (..) + , OneEraForgeStateUpdateError (..) + , OneEraLedgerError (..) + , OneEraLedgerUpdate (..) + , OneEraLedgerWarning (..) + , OneEraTiebreakerView (..) + , OneEraValidationErr (..) + , mkEraMismatch + ) +import Ouroboros.Consensus.HardFork.Combinator.Condense () +import Ouroboros.Consensus.HardFork.History + ( EraParams (eraEpochSize, eraSafeZone, eraSlotLength) + , SafeZone + ) +import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (EraParams)) +import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) +import Ouroboros.Consensus.Ledger.Abstract (LedgerError) +import Ouroboros.Consensus.Ledger.Inspect (LedgerUpdate, LedgerWarning) +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr) +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Protocol.Abstract (TiebreakerView, ValidationErr) +import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util.Condense (Condense (..)) + +-- +-- instances for Header HardForkBlock +-- + +instance All (LogFormatting `Compose` Header) xs => LogFormatting (Header (HardForkBlock xs)) where + forMachine dtal = + hcollapse + . hcmap (Proxy @(LogFormatting `Compose` Header)) (K . forMachine dtal) + . getOneEraHeader + . getHardForkHeader + +-- +-- instances for GenTx HardForkBlock +-- + +instance All (Compose LogFormatting GenTx) xs => LogFormatting (GenTx (HardForkBlock xs)) where + forMachine dtal = + hcollapse + . hcmap (Proxy @(LogFormatting `Compose` GenTx)) (K . forMachine dtal) + . getOneEraGenTx + . getHardForkGenTx + +-- +-- instances for HardForkApplyTxErr +-- + +instance All (LogFormatting `Compose` WrapApplyTxErr) xs => LogFormatting (HardForkApplyTxErr xs) where + forMachine dtal (HardForkApplyTxErrFromEra err) = forMachine dtal err + forMachine _dtal (HardForkApplyTxErrWrongEra mismatch) = + mconcat + [ "kind" .= String "HardForkApplyTxErrWrongEra" + , "currentEra" .= ledgerEraName + , "txEra" .= otherEraName + ] + where + EraMismatch{ledgerEraName, otherEraName} = mkEraMismatch mismatch + +instance All (LogFormatting `Compose` WrapApplyTxErr) xs => LogFormatting (OneEraApplyTxErr xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @(LogFormatting `Compose` WrapApplyTxErr)) (K . forMachine dtal) + . getOneEraApplyTxErr + +instance LogFormatting (ApplyTxErr blk) => LogFormatting (WrapApplyTxErr blk) where + forMachine dtal = forMachine dtal . unwrapApplyTxErr + +-- +-- instances for HardForkLedgerError +-- + +instance All (LogFormatting `Compose` WrapLedgerErr) xs => LogFormatting (HardForkLedgerError xs) where + forMachine dtal (HardForkLedgerErrorFromEra err) = forMachine dtal err + forMachine _dtal (HardForkLedgerErrorWrongEra mismatch) = + mconcat + [ "kind" .= String "HardForkLedgerErrorWrongEra" + , "currentEra" .= ledgerEraName + , "blockEra" .= otherEraName + ] + where + EraMismatch{ledgerEraName, otherEraName} = mkEraMismatch mismatch + +instance All (LogFormatting `Compose` WrapLedgerErr) xs => LogFormatting (OneEraLedgerError xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @(LogFormatting `Compose` WrapLedgerErr)) (K . forMachine dtal) + . getOneEraLedgerError + +instance LogFormatting (LedgerError blk) => LogFormatting (WrapLedgerErr blk) where + forMachine dtal = forMachine dtal . unwrapLedgerErr + +-- +-- instances for HardForkLedgerWarning +-- + +instance + ( All (LogFormatting `Compose` WrapLedgerWarning) xs + , All SingleEraBlock xs + ) => + LogFormatting (HardForkLedgerWarning xs) + where + forMachine dtal warning = case warning of + HardForkWarningInEra err -> forMachine dtal err + HardForkWarningTransitionMismatch toEra eraParams epoch -> + mconcat + [ "kind" .= String "HardForkWarningTransitionMismatch" + , "toEra" .= condense toEra + , "eraParams" .= forMachine dtal eraParams + , "transitionEpoch" .= epoch + ] + HardForkWarningTransitionInFinalEra fromEra epoch -> + mconcat + [ "kind" .= String "HardForkWarningTransitionInFinalEra" + , "fromEra" .= condense fromEra + , "transitionEpoch" .= epoch + ] + HardForkWarningTransitionUnconfirmed toEra -> + mconcat + [ "kind" .= String "HardForkWarningTransitionUnconfirmed" + , "toEra" .= condense toEra + ] + HardForkWarningTransitionReconfirmed fromEra toEra prevEpoch newEpoch -> + mconcat + [ "kind" .= String "HardForkWarningTransitionReconfirmed" + , "fromEra" .= condense fromEra + , "toEra" .= condense toEra + , "prevTransitionEpoch" .= prevEpoch + , "newTransitionEpoch" .= newEpoch + ] + +instance All (LogFormatting `Compose` WrapLedgerWarning) xs => LogFormatting (OneEraLedgerWarning xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @(LogFormatting `Compose` WrapLedgerWarning)) (K . forMachine dtal) + . getOneEraLedgerWarning + +instance LogFormatting (LedgerWarning blk) => LogFormatting (WrapLedgerWarning blk) where + forMachine dtal = forMachine dtal . unwrapLedgerWarning + +instance LogFormatting EraParams where + forMachine _dtal EraParams{eraEpochSize, eraSlotLength, eraSafeZone} = + mconcat + [ "epochSize" .= unEpochSize eraEpochSize + , "slotLength" .= getSlotLength eraSlotLength + , "safeZone" .= eraSafeZone + ] + +deriving instance ToJSON SafeZone + +-- +-- instances for HardForkLedgerUpdate +-- + +instance + ( All (LogFormatting `Compose` WrapLedgerUpdate) xs + , All SingleEraBlock xs + ) => + LogFormatting (HardForkLedgerUpdate xs) + where + forMachine dtal update = case update of + HardForkUpdateInEra err -> forMachine dtal err + HardForkUpdateTransitionConfirmed fromEra toEra epoch -> + mconcat + [ "kind" .= String "HardForkUpdateTransitionConfirmed" + , "fromEra" .= condense fromEra + , "toEra" .= condense toEra + , "transitionEpoch" .= epoch + ] + HardForkUpdateTransitionDone fromEra toEra epoch -> + mconcat + [ "kind" .= String "HardForkUpdateTransitionDone" + , "fromEra" .= condense fromEra + , "toEra" .= condense toEra + , "transitionEpoch" .= epoch + ] + HardForkUpdateTransitionRolledBack fromEra toEra -> + mconcat + [ "kind" .= String "HardForkUpdateTransitionRolledBack" + , "fromEra" .= condense fromEra + , "toEra" .= condense toEra + ] + +instance All (LogFormatting `Compose` WrapLedgerUpdate) xs => LogFormatting (OneEraLedgerUpdate xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @(LogFormatting `Compose` WrapLedgerUpdate)) (K . forMachine dtal) + . getOneEraLedgerUpdate + +instance LogFormatting (LedgerUpdate blk) => LogFormatting (WrapLedgerUpdate blk) where + forMachine dtal = forMachine dtal . unwrapLedgerUpdate + +-- +-- instances for HardForkEnvelopeErr +-- + +instance All (LogFormatting `Compose` WrapEnvelopeErr) xs => LogFormatting (HardForkEnvelopeErr xs) where + forMachine dtal (HardForkEnvelopeErrFromEra err) = forMachine dtal err + forMachine _dtal (HardForkEnvelopeErrWrongEra mismatch) = + mconcat + [ "kind" .= String "HardForkEnvelopeErrWrongEra" + , "currentEra" .= ledgerEraName + , "blockEra" .= otherEraName + ] + where + EraMismatch{ledgerEraName, otherEraName} = mkEraMismatch mismatch + +instance All (LogFormatting `Compose` WrapEnvelopeErr) xs => LogFormatting (OneEraEnvelopeErr xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @(LogFormatting `Compose` WrapEnvelopeErr)) (K . forMachine dtal) + . getOneEraEnvelopeErr + +instance LogFormatting (OtherHeaderEnvelopeError blk) => LogFormatting (WrapEnvelopeErr blk) where + forMachine dtal = forMachine dtal . unwrapEnvelopeErr + +-- +-- instances for HardForkValidationErr +-- + +instance All (LogFormatting `Compose` WrapValidationErr) xs => LogFormatting (HardForkValidationErr xs) where + forMachine dtal (HardForkValidationErrFromEra err) = forMachine dtal err + forMachine _dtal (HardForkValidationErrWrongEra mismatch) = + mconcat + [ "kind" .= String "HardForkValidationErrWrongEra" + , "currentEra" .= ledgerEraName + , "blockEra" .= otherEraName + ] + where + EraMismatch{ledgerEraName, otherEraName} = mkEraMismatch mismatch + +instance All (LogFormatting `Compose` WrapValidationErr) xs => LogFormatting (OneEraValidationErr xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @(LogFormatting `Compose` WrapValidationErr)) (K . forMachine dtal) + . getOneEraValidationErr + +instance LogFormatting (ValidationErr (BlockProtocol blk)) => LogFormatting (WrapValidationErr blk) where + forMachine dtal = forMachine dtal . unwrapValidationErr + +-- +-- instances for HardForkCannotForge +-- + +-- It's a type alias: +-- type HardForkCannotForge xs = OneEraCannotForge xs + +instance All (LogFormatting `Compose` WrapCannotForge) xs => LogFormatting (OneEraCannotForge xs) where + forMachine dtal = + hcollapse + . hcmap + (Proxy @(LogFormatting `Compose` WrapCannotForge)) + (K . forMachine dtal) + . getOneEraCannotForge + +instance LogFormatting (CannotForge blk) => LogFormatting (WrapCannotForge blk) where + forMachine dtal = forMachine dtal . unwrapCannotForge + +-- +-- instances for HardForkForgeStateInfo +-- + +-- It's a type alias: +-- type HardForkForgeStateInfo xs = OneEraForgeStateInfo xs + +instance All (LogFormatting `Compose` WrapForgeStateInfo) xs => LogFormatting (OneEraForgeStateInfo xs) where + forMachine dtal forgeStateInfo = + mconcat + [ "kind" .= String "HardForkForgeStateInfo" + , "forgeStateInfo" .= toJSON forgeStateInfo' + ] + where + forgeStateInfo' :: Object + forgeStateInfo' = + hcollapse + . hcmap + (Proxy @(LogFormatting `Compose` WrapForgeStateInfo)) + (K . forMachine dtal) + . getOneEraForgeStateInfo + $ forgeStateInfo + +instance LogFormatting (ForgeStateInfo blk) => LogFormatting (WrapForgeStateInfo blk) where + forMachine dtal = forMachine dtal . unwrapForgeStateInfo + +-- +-- instances for HardForkForgeStateUpdateError +-- + +-- It's a type alias: +-- type HardForkForgeStateUpdateError xs = OneEraForgeStateUpdateError xs + +instance + All (LogFormatting `Compose` WrapForgeStateUpdateError) xs => + LogFormatting (OneEraForgeStateUpdateError xs) + where + forMachine dtal forgeStateUpdateError = + mconcat + [ "kind" .= String "HardForkForgeStateUpdateError" + , "forgeStateUpdateError" .= toJSON forgeStateUpdateError' + ] + where + forgeStateUpdateError' :: Object + forgeStateUpdateError' = + hcollapse + . hcmap + (Proxy @(LogFormatting `Compose` WrapForgeStateUpdateError)) + (K . forMachine dtal) + . getOneEraForgeStateUpdateError + $ forgeStateUpdateError + +instance LogFormatting (ForgeStateUpdateError blk) => LogFormatting (WrapForgeStateUpdateError blk) where + forMachine dtal = forMachine dtal . unwrapForgeStateUpdateError + +-- +-- instances for HardForkSelectView +-- + +instance All (LogFormatting `Compose` WrapTiebreakerView) xs => LogFormatting (HardForkTiebreakerView xs) where + forMachine dtal = forMachine dtal . getHardForkTiebreakerView + +instance LogFormatting (TiebreakerView protocol) => LogFormatting (WeightedSelectView protocol) where + forMachine dtal sv = + mconcat + [ "blockNo" .= wsvBlockNo sv + , "weightBoost" .= unPerasWeight (wsvWeightBoost sv) + , forMachine dtal (wsvTiebreaker sv) + ] + +instance All (LogFormatting `Compose` WrapTiebreakerView) xs => LogFormatting (OneEraTiebreakerView xs) where + forMachine dtal = + hcollapse + . hcmap + (Proxy @(LogFormatting `Compose` WrapTiebreakerView)) + (K . forMachine dtal) + . getOneEraTiebreakerView + +instance LogFormatting (TiebreakerView (BlockProtocol blk)) => LogFormatting (WrapTiebreakerView blk) where + forMachine dtal = forMachine dtal . unwrapTiebreakerView diff --git a/tracing/Ouroboros/Consensus/Tracing/Era/Shelley.hs b/tracing/Ouroboros/Consensus/Tracing/Era/Shelley.hs new file mode 100644 index 0000000000..a375e9a321 --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/Era/Shelley.hs @@ -0,0 +1,1948 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ouroboros.Consensus.Tracing.Era.Shelley () where + +import qualified Cardano.Crypto.Hash.Class as Crypto +import qualified Cardano.Crypto.VRF.Class as Crypto +import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) +import qualified Cardano.Ledger.Allegra.Rules as Allegra +import qualified Cardano.Ledger.Allegra.Scripts as Allegra +import qualified Cardano.Ledger.Alonzo.Plutus.Evaluate as Alonzo +import Cardano.Ledger.Alonzo.Rules + ( AlonzoBbodyPredFailure + , AlonzoUtxoPredFailure + , AlonzoUtxosPredFailure + , AlonzoUtxowPredFailure (..) + ) +import qualified Cardano.Ledger.Alonzo.Rules as Alonzo +import Cardano.Ledger.Api.Scripts (AnyEraScript) +import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) +import qualified Cardano.Ledger.Babbage.Rules as Babbage +import Cardano.Ledger.BaseTypes (Mismatch (..), activeSlotLog, strictMaybeToMaybe) +import Cardano.Ledger.Binary (serialize') +import Cardano.Ledger.Chain +import Cardano.Ledger.Conway.Governance (govActionIdToText) +import qualified Cardano.Ledger.Conway.Rules as Conway +import qualified Cardano.Ledger.Core as Ledger +import qualified Cardano.Ledger.Core as SL +import qualified Cardano.Ledger.Dijkstra.Rules as Dijkstra +import qualified Cardano.Ledger.Hashes as Hashes +import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Shelley.Rules +import Cardano.Logging +import qualified Cardano.Protocol.Crypto as Ledger +import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) +import Cardano.Protocol.TPraos.BlockHeader (LastAppliedBlock, labBlockNo) +import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod)) +import Cardano.Protocol.TPraos.Rules.OCert +import Cardano.Protocol.TPraos.Rules.Overlay +import Cardano.Protocol.TPraos.Rules.Prtcl + ( PrtclPredicateFailure (OverlayFailure, UpdnFailure) + , PrtlSeqFailure (WrongBlockNoPrtclSeq, WrongBlockSequencePrtclSeq, WrongSlotIntervalPrtclSeq) + ) +import Cardano.Protocol.TPraos.Rules.Updn (UpdnPredicateFailure) +import Cardano.Slotting.Block (BlockNo (..)) +import Control.DeepSeq (NFData) +import Data.Aeson (ToJSON (..), ToJSONKey, Value (..), (.=)) +import qualified Data.Aeson.Key as Aeson (fromText) +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Base16 as B16 +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Map.NonEmpty as NonEmptyMap +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Set.NonEmpty as NonEmptySet +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Ouroboros.Consensus.Protocol.Praos as Praos +import qualified Ouroboros.Consensus.Protocol.Praos.Common as Praos +import Ouroboros.Consensus.Protocol.TPraos (TPraosCannotForge (..)) +import Ouroboros.Consensus.Shelley.Ledger hiding (TxId) +import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus +import Ouroboros.Consensus.Shelley.Ledger.Inspect +import qualified Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks as Praos (EnvelopeError (..)) +import Ouroboros.Consensus.Tracing.ConvertTxId (ConvertTxId) +import Ouroboros.Consensus.Tracing.Era.Shelley.Render + ( renderIncompleteWithdrawals + , renderMissingRedeemers + , renderRewardAccount + , renderScriptHash + , renderScriptIndex + , renderScriptIntegrityHash + ) +import Ouroboros.Consensus.Tracing.Render (renderTxId) +import Ouroboros.Consensus.Util.Condense (condense) +import Ouroboros.Network.Block (SlotNo (..), blockHash, blockNo, blockSlot) +import Ouroboros.Network.Point (WithOrigin, withOriginToMaybe) + +textShow :: Show a => a -> Text +textShow = Text.pack . show + +-- | Render a non-empty set\/map as a plain JSON array\/object. +-- +-- @cardano-data@ only gained @ToJSON@ instances for @NonEmptySet@ and +-- @NonEmptyMap@ in 1.3.1.0, and we build against 1.3.0.0, so going through the +-- underlying 'Set' \/ 'Map' is what works either way. It is also what those +-- instances do -- they are derived from the container being wrapped -- so the +-- rendering does not depend on which version ends up in the build plan. +jsonNonEmptySet :: ToJSON a => NonEmptySet.NonEmptySet a -> Value +jsonNonEmptySet = toJSON . NonEmptySet.toSet + +jsonNonEmptyMap :: (ToJSONKey k, ToJSON v) => NonEmptyMap.NonEmptyMap k v -> Value +jsonNonEmptyMap = toJSON . NonEmptyMap.toMap + +-- + +-- | instances of @LogFormatting@ +-- +-- NOTE: this list is sorted in roughly topological order. +instance + ( ConvertTxId (ShelleyBlock protocol era) + , ShelleyBasedEra era + ) => + LogFormatting (GenTx (ShelleyBlock protocol era)) + where + forMachine dtal (Ouroboros.Consensus.Shelley.Ledger.ShelleyTx txid tx) = + mconcat $ + ("txid" .= (Text.take 8 $ renderTxId @(ShelleyBlock protocol era) $ ShelleyTxId txid)) + -- We want to emit only the CBOR hex of the tx, not the decoded tx itself. + : [ "tx" .= Text.Encoding.decodeLatin1 (B16.encode (serialize' (SL.eraProtVerLow @era) tx)) + | dtal == DDetailed + ] + +kesPeriodValue :: KESPeriod -> Value +kesPeriodValue (KESPeriod period) = toJSON period + +instance LogFormatting (Set (Credential Staking)) where + forMachine _dtal creds = + mconcat + [ "kind" .= String "StakeCreds" + , "stakeCreds" .= map toJSON (Set.toList creds) + ] + +instance LogFormatting (NonEmpty.NonEmpty (KeyHash Staking)) where + forMachine _dtal keyHashes = + mconcat + [ "kind" .= String "StakingKeyHashes" + , "stakeKeyHashes" .= toJSON keyHashes + ] + +instance + ( LogFormatting (PredicateFailure (Ledger.EraRule "DELEG" era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "POOL" era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "GOVCERT" era)) + ) => + LogFormatting (Conway.ConwayCertPredFailure era) + where + forMachine dtal = + mconcat . \case + Conway.DelegFailure f -> + ["kind" .= String "DelegFailure ", "failure" .= forMachine dtal f] + Conway.PoolFailure f -> + ["kind" .= String "PoolFailure", "failure" .= forMachine dtal f] + Conway.GovCertFailure f -> + ["kind" .= String "GovCertFailure", "failure" .= forMachine dtal f] + +instance LogFormatting (Conway.ConwayGovCertPredFailure era) where + forMachine _dtal = + mconcat . \case + Conway.ConwayDRepAlreadyRegistered credential -> + [ "kind" .= String "ConwayDRepAlreadyRegistered" + , "credential" .= String (textShow credential) + , "error" .= String "DRep is already registered" + ] + Conway.ConwayDRepNotRegistered credential -> + [ "kind" .= String "ConwayDRepNotRegistered" + , "credential" .= String (textShow credential) + , "error" .= String "DRep is not registered" + ] + Conway.ConwayDRepIncorrectDeposit Mismatch{mismatchSupplied, mismatchExpected} -> + [ "kind" .= String "ConwayDRepIncorrectDeposit" + , "givenCoin" .= mismatchSupplied + , "expectedCoin" .= mismatchExpected + , "error" .= String "DRep delegation has incorrect deposit" + ] + Conway.ConwayCommitteeHasPreviouslyResigned coldCred -> + [ "kind" .= String "ConwayCommitteeHasPreviouslyResigned" + , "credential" .= String (textShow coldCred) + , "error" .= String "Committee has resigned" + ] + Conway.ConwayCommitteeIsUnknown coldCred -> + [ "kind" .= String "ConwayCommitteeIsUnknown" + , "credential" .= String (textShow coldCred) + , "error" .= String "Committee is Unknown" + ] + Conway.ConwayDRepIncorrectRefund Mismatch{mismatchSupplied, mismatchExpected} -> + [ "kind" .= String "ConwayDRepIncorrectRefund" + , "givenRefund" .= mismatchSupplied + , "expectedRefund" .= mismatchExpected + , "error" .= String "Refunds mismatch" + ] + +instance LogFormatting (Conway.ConwayDelegPredFailure era) where + forMachine _dtal = + mconcat . \case + Conway.DelegateeStakePoolNotRegisteredDELEG poolID -> + [ "kind" .= String "DelegateeStakePoolNotRegisteredDELEG" + , "poolID" .= String (textShow poolID) + ] + Conway.IncorrectDepositDELEG coin -> + [ "kind" .= String "IncorrectDepositDELEG" + , "amount" .= coin + , "error" .= String "Incorrect deposit amount" + ] + Conway.DelegAccountAlreadyRegistered (AccountAlreadyRegistered credential) -> + [ "kind" .= String "DelegAccountAlreadyRegistered" + , "credential" .= String (textShow credential) + , "error" .= String "Stake key already registered" + ] + Conway.StakeKeyNotRegisteredDELEG credential -> + [ "kind" .= String "StakeKeyNotRegisteredDELEG" + , "amount" .= String (textShow credential) + , "error" .= String "Stake key not registered" + ] + Conway.StakeKeyHasNonZeroAccountBalanceDELEG coin -> + [ "kind" .= String "StakeKeyHasNonZeroAccountBalanceDELEG" + , "amount" .= coin + , "error" .= String "Stake key has non-zero account balance" + ] + Conway.DelegateeDRepNotRegisteredDELEG credential -> + [ "kind" .= String "DelegateeDRepNotRegisteredDELEG" + , "credential" .= String (textShow credential) + , "error" .= String "Delegated rep is not registered for provided stake key" + ] + Conway.DepositIncorrectDELEG Mismatch{mismatchSupplied, mismatchExpected} -> + [ "kind" .= String "DepositIncorrectDELEG" + , "givenRefund" .= mismatchSupplied + , "expectedRefund" .= mismatchExpected + , "error" .= String "Deposit mismatch" + ] + Conway.RefundIncorrectDELEG Mismatch{mismatchSupplied, mismatchExpected} -> + [ "kind" .= String "RefundIncorrectDELEG" + , "givenRefund" .= mismatchSupplied + , "expectedRefund" .= mismatchExpected + , "error" .= String "Refund mismatch" + ] + +instance + ShelleyCompatible protocol era => + LogFormatting (Header (ShelleyBlock protocol era)) + where + forMachine _dtal b = + mconcat + [ "kind" .= String "ShelleyBlock" + , "hash" .= condense (blockHash b) + , "slotNo" .= condense (blockSlot b) + , "blockNo" .= condense (blockNo b) + -- , "delegate" .= condense (headerSignerVk h) + ] + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "LEDGER" era)) + , ToJSON (ApplyTxError era) + ) => + LogFormatting (ApplyTxError era) + where + forMachine _dtal err = + mconcat + [ "kind" .= String "ApplyTxError" + , "reason" .= toJSON err + ] + +instance + Ledger.Crypto era => + LogFormatting (TPraosCannotForge era) + where + forMachine _dtal (TPraosCannotForgeKeyNotUsableYet wallClockPeriod keyStartPeriod) = + mconcat + [ "kind" .= String "TPraosCannotForgeKeyNotUsableYet" + , "keyStart" .= kesPeriodValue keyStartPeriod + , "wallClock" .= kesPeriodValue wallClockPeriod + ] + forMachine _dtal (TPraosCannotForgeWrongVRF genDlgVRFHash coreNodeVRFHash) = + mconcat + [ "kind" .= String "TPraosCannotLeadWrongVRF" + , "expected" .= genDlgVRFHash + , "actual" .= coreNodeVRFHash + ] + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "BBODY" era)) + , NFData (PredicateFailure (Ledger.EraRule "BBODY" era)) + ) => + LogFormatting (BlockTransitionError era) + where + forMachine dtal (BlockTransitionError fs) = + mconcat + [ "kind" .= String "BlockTransitionError" + , "failures" .= fmap (forMachine dtal) fs + ] + +instance + ( Consensus.ShelleyBasedEra era + , ToJSON (Ledger.PParamsUpdate era) + ) => + LogFormatting (ShelleyLedgerUpdate era) + where + forMachine _dtal (ShelleyUpdatedPParams updates epochNo) = + mconcat + [ "kind" .= String "ShelleyUpdatedProtocolUpdates" + , "updates" .= show updates + , "epochNo" .= show epochNo + ] + +instance + Ledger.Crypto crypto => + LogFormatting (ChainTransitionError crypto) + where + forMachine dtal (ChainTransitionError fs) = + mconcat + [ "kind" .= String "ChainTransitionError" + , "failures" .= fmap (forMachine dtal) fs + ] + +instance LogFormatting ChainPredicateFailure where + forMachine _dtal (HeaderSizeTooLargeCHAIN hdrSz maxHdrSz) = + mconcat + [ "kind" .= String "HeaderSizeTooLarge" + , "headerSize" .= hdrSz + , "maxHeaderSize" .= maxHdrSz + ] + forMachine _dtal (BlockSizeTooLargeCHAIN blkSz maxBlkSz) = + mconcat + [ "kind" .= String "BlockSizeTooLarge" + , "blockSize" .= blkSz + , "maxBlockSize" .= maxBlkSz + ] + forMachine _dtal (ObsoleteNodeCHAIN currentPtcl supportedPtcl) = + mconcat + [ "kind" .= String "ObsoleteNode" + , "explanation" .= String explanation + , "currentProtocol" .= currentPtcl + , "supportedProtocol" .= supportedPtcl + ] + where + explanation = + mconcat + [ "A scheduled major protocol version change (hard fork) " + , "has taken place on the chain, but this node does not " + , "understand the new major protocol version. This node " + , "must be upgraded before it can continue with the new " + , "protocol version." + ] + +instance LogFormatting PrtlSeqFailure where + forMachine _dtal (WrongSlotIntervalPrtclSeq (SlotNo lastSlot) (SlotNo currSlot)) = + mconcat + [ "kind" .= String "WrongSlotInterval" + , "lastSlot" .= lastSlot + , "currentSlot" .= currSlot + ] + forMachine _dtal (WrongBlockNoPrtclSeq lab currentBlockNo) = + mconcat + [ "kind" .= String "WrongBlockNo" + , "lastAppliedBlockNo" .= showLastAppBlockNo lab + , "currentBlockNo" .= (String . textShow $ unBlockNo currentBlockNo) + ] + forMachine _dtal (WrongBlockSequencePrtclSeq lastAppliedHash currentHash) = + mconcat + [ "kind" .= String "WrongBlockSequence" + , "lastAppliedBlockHash" .= String (textShow lastAppliedHash) + , "currentBlockHash" .= String (textShow currentHash) + ] + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "LEDGER" era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "LEDGERS" era)) + ) => + LogFormatting (ShelleyBbodyPredFailure era) + where + forMachine + _dtal + ( WrongBlockBodySizeBBODY + Mismatch + { mismatchSupplied = actualBodySz + , mismatchExpected = claimedBodySz + } + ) = + mconcat + [ "kind" .= String "WrongBlockBodySizeBBODY" + , "actualBlockBodySize" .= actualBodySz + , "claimedBlockBodySize" .= claimedBodySz + ] + forMachine + _dtal + ( InvalidBodyHashBBODY + Mismatch + { mismatchSupplied = actualHash + , mismatchExpected = claimedHash + } + ) = + mconcat + [ "kind" .= String "InvalidBodyHashBBODY" + , "actualBodyHash" .= textShow actualHash + , "claimedBodyHash" .= textShow claimedHash + ] + forMachine dtal (LedgersFailure f) = forMachine dtal f + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "LEDGER" era)) + ) => + LogFormatting (ShelleyLedgersPredFailure era) + where + forMachine dtal (LedgerFailure f) = forMachine dtal f + +instance LogFormatting Withdrawals where + forMachine _dtal (Withdrawals ws) = + mconcat + [ "kind" .= String "Withdrawals" + , "withdrawals" .= Aeson.object (map renderTuple $ Map.toList ws) + ] + where + renderTuple :: (Ledger.AccountAddress, Coin) -> Aeson.Pair + renderTuple (address, mismatch) = + Aeson.fromText (renderRewardAccount address) .= show mismatch + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "DELEGS" era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXOW" era)) + ) => + LogFormatting (ShelleyLedgerPredFailure era) + where + forMachine dtal = \case + UtxowFailure f -> forMachine dtal f + DelegsFailure f -> forMachine dtal f + ShelleyWithdrawalsMissingAccounts withdrawals -> forMachine dtal withdrawals + ShelleyIncompleteWithdrawals payload -> + mconcat + [ "kind" .= String "ShelleyIncompleteWithdrawals" + , "withdrawals" .= renderIncompleteWithdrawals payload + ] + +instance + ( AnyEraScript ledgerera + , Consensus.ShelleyBasedEra ledgerera + , LogFormatting (Ledger.EraRuleFailure "PPUP" ledgerera) + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" ledgerera)) + ) => + LogFormatting (AlonzoUtxowPredFailure ledgerera) + where + forMachine dtal (ShelleyInAlonzoUtxowPredFailure utxoPredFail) = + forMachine dtal utxoPredFail + forMachine _ (MissingRedeemers scripts) = + mconcat + [ "kind" .= String "MissingRedeemers" + , "scripts" .= renderMissingRedeemers scripts + ] + forMachine _ (MissingRequiredDatums required received) = + mconcat + [ "kind" .= String "MissingRequiredDatums" + , "required" + .= map + (Crypto.hashToTextAsHex . Hashes.extractHash) + (NonEmptySet.toList required) + , "received" + .= map + (Crypto.hashToTextAsHex . Hashes.extractHash) + (Set.toList received) + ] + forMachine _ (PPViewHashesDontMatch Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "PPViewHashesDontMatch" + , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) + , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) + ] + forMachine _ (UnspendableUTxONoDatumHash txins) = + mconcat + [ "kind" .= String "MissingRequiredSigners" + , "txins" .= NonEmptySet.toList txins + ] + forMachine _ (NotAllowedSupplementalDatums disallowed acceptable) = + mconcat + [ "kind" .= String "NotAllowedSupplementalDatums" + , "disallowed" .= NonEmptySet.toList disallowed + , "acceptable" .= Set.toList acceptable + ] + forMachine _ (ExtraRedeemers rdmrs) = + mconcat + [ "kind" .= String "ExtraRedeemers" + , "rdmrs" .= map renderScriptIndex (NonEmpty.toList rdmrs) + ] + forMachine _ (ScriptIntegrityHashMismatch Mismatch{mismatchSupplied, mismatchExpected} mBytes) = + mconcat + [ "kind" .= String "ScriptIntegrityHashMismatch" + , "supplied" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) + , "expected" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) + , "hashHexPreimage" .= formatAsHex (strictMaybeToMaybe mBytes) + ] + +formatAsHex :: Maybe Crypto.ByteString -> String +formatAsHex Nothing = "" +formatAsHex (Just bs) = show bs + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era)) + ) => + LogFormatting (ShelleyUtxowPredFailure era) + where + forMachine _dtal (InvalidWitnessesUTXOW wits') = + mconcat + [ "kind" .= String "InvalidWitnessesUTXOW" + , "invalidWitnesses" .= map textShow (NonEmpty.toList wits') + ] + forMachine _dtal (MissingVKeyWitnessesUTXOW wits') = + mconcat + [ "kind" .= String "MissingVKeyWitnessesUTXOW" + , "missingWitnesses" .= jsonNonEmptySet wits' + ] + forMachine _dtal (MissingScriptWitnessesUTXOW missingScripts) = + mconcat + [ "kind" .= String "MissingScriptWitnessesUTXOW" + , "missingScripts" .= jsonNonEmptySet missingScripts + ] + forMachine _dtal (ScriptWitnessNotValidatingUTXOW failedScripts) = + mconcat + [ "kind" .= String "ScriptWitnessNotValidatingUTXOW" + , "failedScripts" .= jsonNonEmptySet failedScripts + ] + forMachine dtal (UtxoFailure f) = forMachine dtal f + forMachine _dtal (MIRInsufficientGenesisSigsUTXOW genesisSigs) = + mconcat + [ "kind" .= String "MIRInsufficientGenesisSigsUTXOW" + , "genesisSigs" .= genesisSigs + ] + forMachine _dtal (MissingTxBodyMetadataHash metadataHash) = + mconcat + [ "kind" .= String "MissingTxBodyMetadataHash" + , "metadataHash" .= metadataHash + ] + forMachine _dtal (MissingTxMetadata txBodyMetadataHash) = + mconcat + [ "kind" .= String "MissingTxMetadata" + , "txBodyMetadataHash" .= txBodyMetadataHash + ] + forMachine + _dtal + ( ConflictingMetadataHash + Mismatch + { mismatchSupplied = txBodyMetadataHash + , mismatchExpected = fullMetadataHash + } + ) = + mconcat + [ "kind" .= String "ConflictingMetadataHash" + , "txBodyMetadataHash" .= txBodyMetadataHash + , "fullMetadataHash" .= fullMetadataHash + ] + forMachine _dtal InvalidMetadata = + mconcat + [ "kind" .= String "InvalidMetadata" + ] + forMachine _dtal (ExtraneousScriptWitnessesUTXOW scriptHashes) = + mconcat + [ "kind" .= String "ExtraneousScriptWitnessesUTXOW" + , "scriptHashes" .= Set.map renderScriptHash (NonEmptySet.toSet scriptHashes) + ] + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (Ledger.EraRuleFailure "PPUP" era) + ) => + LogFormatting (ShelleyUtxoPredFailure era) + where + forMachine _dtal (BadInputsUTxO badInputs) = + mconcat + [ "kind" .= String "BadInputsUTxO" + , "badInputs" .= jsonNonEmptySet badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) + ] + forMachine _dtal (ExpiredUTxO Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "ExpiredUTxO" + , "ttl" .= mismatchSupplied + , "slot" .= mismatchExpected + ] + forMachine + _dtal + ( MaxTxSizeUTxO + Mismatch + { mismatchSupplied = txsize + , mismatchExpected = maxtxsize + } + ) = + mconcat + [ "kind" .= String "MaxTxSizeUTxO" + , "size" .= txsize + , "maxSize" .= maxtxsize + ] + -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO + forMachine _dtal (OutputTooSmallUTxO badOutputs) = + mconcat + [ "kind" .= String "OutputTooSmallUTxO" + , "outputs" .= badOutputs + , "error" + .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] + forMachine _dtal (OutputBootAddrAttrsTooBig badOutputs) = + mconcat + [ "kind" .= String "OutputBootAddrAttrsTooBig" + , "outputs" .= badOutputs + , "error" .= String "The Byron address attributes are too big" + ] + forMachine _dtal InputSetEmptyUTxO = + mconcat ["kind" .= String "InputSetEmptyUTxO"] + -- TODO are these arguments in the right order? + forMachine + _dtal + ( FeeTooSmallUTxO + Mismatch + { mismatchSupplied = minfee + , mismatchExpected = txfee + } + ) = + mconcat + [ "kind" .= String "FeeTooSmallUTxO" + , "minimum" .= minfee + , "fee" .= txfee + ] + forMachine _dtal (ValueNotConservedUTxO Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "ValueNotConservedUTxO" + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected + ] + forMachine dtal (UpdateFailure f) = forMachine dtal f + forMachine _dtal (WrongNetwork network addrs) = + mconcat + [ "kind" .= String "WrongNetwork" + , "network" .= network + , "addrs" .= jsonNonEmptySet addrs + ] + forMachine _dtal (WrongNetworkWithdrawal network addrs) = + mconcat + [ "kind" .= String "WrongNetworkWithdrawal" + , "network" .= network + , "addrs" .= jsonNonEmptySet addrs + ] + +instance + ( Consensus.ShelleyBasedEra era + , ToJSON Allegra.ValidityInterval + , LogFormatting (Ledger.EraRuleFailure "PPUP" era) + ) => + LogFormatting (AllegraUtxoPredFailure era) + where + forMachine _dtal (Allegra.BadInputsUTxO badInputs) = + mconcat + [ "kind" .= String "BadInputsUTxO" + , "badInputs" .= jsonNonEmptySet badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) + ] + forMachine _dtal (Allegra.OutsideValidityIntervalUTxO validityInterval slot) = + mconcat + [ "kind" .= String "ExpiredUTxO" + , "validityInterval" .= validityInterval + , "slot" .= slot + ] + forMachine _dtal (Allegra.MaxTxSizeUTxO Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "MaxTxSizeUTxO" + , "size" .= mismatchSupplied + , "maxSize" .= mismatchExpected + ] + forMachine _dtal Allegra.InputSetEmptyUTxO = + mconcat ["kind" .= String "InputSetEmptyUTxO"] + forMachine _dtal (Allegra.FeeTooSmallUTxO Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "FeeTooSmallUTxO" + , "minimum" .= mismatchExpected + , "fee" .= mismatchSupplied + ] + forMachine _dtal (Allegra.ValueNotConservedUTxO Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "ValueNotConservedUTxO" + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected + ] + forMachine _dtal (Allegra.WrongNetwork network addrs) = + mconcat + [ "kind" .= String "WrongNetwork" + , "network" .= network + , "addrs" .= jsonNonEmptySet addrs + ] + forMachine _dtal (Allegra.WrongNetworkWithdrawal network addrs) = + mconcat + [ "kind" .= String "WrongNetworkWithdrawal" + , "network" .= network + , "addrs" .= jsonNonEmptySet addrs + ] + -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO + forMachine _dtal (Allegra.OutputTooSmallUTxO badOutputs) = + mconcat + [ "kind" .= String "OutputTooSmallUTxO" + , "outputs" .= badOutputs + , "error" + .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] + forMachine dtal (Allegra.UpdateFailure f) = forMachine dtal f + forMachine _dtal (Allegra.OutputBootAddrAttrsTooBig badOutputs) = + mconcat + [ "kind" .= String "OutputBootAddrAttrsTooBig" + , "outputs" .= badOutputs + , "error" .= String "The Byron address attributes are too big" + ] + forMachine _dtal (Allegra.OutputTooBigUTxO badOutputs) = + mconcat + [ "kind" .= String "OutputTooBigUTxO" + , "outputs" .= badOutputs + , "error" .= String "Too many asset ids in the tx output" + ] + +renderBadInputsUTxOErr :: Set TxIn -> Value +renderBadInputsUTxOErr txIns + | Set.null txIns = String "The transaction contains no inputs." + | otherwise = String "The transaction contains inputs that do not exist in the UTxO set." + +renderValueNotConservedErr :: Show val => val -> val -> Value +renderValueNotConservedErr consumed produced = + String $ + "This transaction consumed " <> textShow consumed <> " but produced " <> textShow produced + +instance LogFormatting (ShelleyPpupPredFailure era) where + -- TODO are these arguments in the right order? + forMachine + _dtal + ( NonGenesisUpdatePPUP + Mismatch + { mismatchSupplied = proposalKeys + , mismatchExpected = genesisKeys + } + ) = + mconcat + [ "kind" .= String "NonGenesisUpdatePPUP" + , "keys" .= proposalKeys Set.\\ genesisKeys + ] + forMachine _dtal (PPUpdateWrongEpoch currEpoch intendedEpoch votingPeriod) = + mconcat + [ "kind" .= String "PPUpdateWrongEpoch" + , "currentEpoch" .= currEpoch + , "intendedEpoch" .= intendedEpoch + , "votingPeriod" .= String (textShow votingPeriod) + ] + forMachine _dtal (PVCannotFollowPPUP badPv) = + mconcat + [ "kind" .= String "PVCannotFollowPPUP" + , "badProtocolVersion" .= badPv + ] + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (Ledger.EraRule "DELPL" era)) + ) => + LogFormatting (ShelleyDelegsPredFailure era) + where + forMachine dtal (DelplFailure f) = forMachine dtal f + +instance + ( LogFormatting (PredicateFailure (Ledger.EraRule "POOL" era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "DELEG" era)) + ) => + LogFormatting (ShelleyDelplPredFailure era) + where + forMachine dtal (PoolFailure f) = forMachine dtal f + forMachine dtal (DelegFailure f) = forMachine dtal f + +instance LogFormatting (ShelleyDelegPredFailure era) where + forMachine _dtal (DelegAccountAlreadyRegistered (AccountAlreadyRegistered alreadyRegistered)) = + mconcat + [ "kind" .= String "DelegAccountAlreadyRegistered" + , "credential" .= String (textShow alreadyRegistered) + , "error" .= String "Staking credential already registered" + ] + forMachine _dtal (StakeKeyNotRegisteredDELEG notRegistered) = + mconcat + [ "kind" .= String "StakeKeyNotRegisteredDELEG" + , "credential" .= String (textShow notRegistered) + , "error" .= String "Staking credential not registered" + ] + forMachine _dtal (StakeKeyNonZeroAccountBalanceDELEG remBalance) = + mconcat + [ "kind" .= String "StakeKeyNonZeroAccountBalanceDELEG" + , "remainingBalance" .= remBalance + ] + forMachine _dtal (StakeDelegationImpossibleDELEG unregistered) = + mconcat + [ "kind" .= String "StakeDelegationImpossibleDELEG" + , "credential" .= String (textShow unregistered) + , "error" .= String "Cannot delegate this stake credential because it is not registered" + ] + forMachine _dtal WrongCertificateTypeDELEG = + mconcat ["kind" .= String "WrongCertificateTypeDELEG"] + forMachine _dtal (GenesisKeyNotInMappingDELEG (KeyHash genesisKeyHash)) = + mconcat + [ "kind" .= String "GenesisKeyNotInMappingDELEG" + , "unknownKeyHash" .= String (textShow genesisKeyHash) + , "error" .= String "This genesis key is not in the delegation mapping" + ] + forMachine _dtal (DuplicateGenesisDelegateDELEG (KeyHash genesisKeyHash)) = + mconcat + [ "kind" .= String "DuplicateGenesisDelegateDELEG" + , "duplicateKeyHash" .= String (textShow genesisKeyHash) + , "error" .= String "This genesis key has already been delegated to" + ] + forMachine _dtal (InsufficientForInstantaneousRewardsDELEG mirpot Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "InsufficientForInstantaneousRewardsDELEG" + , "pot" + .= String + ( case mirpot of + ReservesMIR -> "Reserves" + TreasuryMIR -> "Treasury" + ) + , "neededAmount" .= mismatchSupplied + , "reserves" .= mismatchExpected + ] + forMachine _dtal (MIRCertificateTooLateinEpochDELEG Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "MIRCertificateTooLateinEpochDELEG" + , "currentSlotNo" .= mismatchSupplied + , "mustBeSubmittedBeforeSlotNo" .= mismatchExpected + ] + forMachine _dtal (DuplicateGenesisVRFDELEG vrfKeyHash) = + mconcat + [ "kind" .= String "DuplicateGenesisVRFDELEG" + , "keyHash" .= String (Crypto.hashToTextAsHex (Hashes.unVRFVerKeyHash vrfKeyHash)) + ] + forMachine _dtal MIRTransferNotCurrentlyAllowed = + mconcat + [ "kind" .= String "MIRTransferNotCurrentlyAllowed" + ] + forMachine _dtal MIRNegativesNotCurrentlyAllowed = + mconcat + [ "kind" .= String "MIRNegativesNotCurrentlyAllowed" + ] + forMachine _dtal (InsufficientForTransferDELEG mirpot Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "DuplicateGenesisVRFDELEG" + , "pot" + .= String + ( case mirpot of + ReservesMIR -> "Reserves" + TreasuryMIR -> "Treasury" + ) + , "attempted" .= mismatchSupplied + , "available" .= mismatchExpected + ] + forMachine _dtal MIRProducesNegativeUpdate = + mconcat + [ "kind" .= String "MIRProducesNegativeUpdate" + ] + forMachine _dtal (MIRNegativeTransfer mirpot coin) = + mconcat + [ "kind" .= String "MIRProducesNegativeUpdate" + , "pot" + .= String + ( case mirpot of + ReservesMIR -> "Reserves" + TreasuryMIR -> "Treasury" + ) + , "coin" .= coin + ] + forMachine _dtal (DelegateeNotRegisteredDELEG targetPool) = + mconcat + [ "kind" .= String "DelegateeNotRegisteredDELEG" + , "targetPool" .= targetPool + ] + +instance LogFormatting (ShelleyPoolPredFailure era) where + forMachine _dtal (StakePoolNotRegisteredOnKeyPOOL (KeyHash unregStakePool)) = + mconcat + [ "kind" .= String "StakePoolNotRegisteredOnKeyPOOL" + , "unregisteredKeyHash" .= String (textShow unregStakePool) + , "error" .= String "This stake pool key hash is unregistered" + ] + forMachine + _dtal + ( StakePoolRetirementWrongEpochPOOL + -- inspired by Ledger's Test.Cardano.Ledger.Generic.PrettyCore + -- but is it correct here? + Mismatch{mismatchExpected = currentEpoch} + Mismatch + { mismatchSupplied = intendedRetireEpoch + , mismatchExpected = maxRetireEpoch + } + ) = + mconcat + [ "kind" .= String "StakePoolRetirementWrongEpochPOOL" + , "currentEpoch" .= String (textShow currentEpoch) + , "intendedRetirementEpoch" .= String (textShow intendedRetireEpoch) + , "maxEpochForRetirement" .= String (textShow maxRetireEpoch) + ] + -- TODO are these supplied in the right order? + forMachine + _dtal + ( StakePoolCostTooLowPOOL + Mismatch + { mismatchSupplied = certCost + , mismatchExpected = protCost + } + ) = + mconcat + [ "kind" .= String "StakePoolCostTooLowPOOL" + , "certificateCost" .= String (textShow certCost) + , "protocolParCost" .= String (textShow protCost) + , "error" .= String "The stake pool cost is too low" + ] + forMachine _dtal (PoolMedataHashTooBig poolID hashSize) = + mconcat + [ "kind" .= String "PoolMedataHashTooBig" + , "hashSize" .= String (textShow poolID) + , "poolID" .= String (textShow hashSize) + , "error" .= String "The stake pool metadata hash is too large" + ] + forMachine + _dtal + ( WrongNetworkPOOL + Mismatch + { mismatchSupplied = networkId + , mismatchExpected = listedNetworkId + } + poolId + ) = + mconcat + [ "kind" .= String "WrongNetworkPOOL" + , "networkId" .= String (textShow networkId) + , "listedNetworkId" .= String (textShow listedNetworkId) + , "poolId" .= String (textShow poolId) + , "error" .= String "Wrong network ID in pool registration certificate" + ] + forMachine _dtal (VRFKeyHashAlreadyRegistered poolId vrfKeyHash) = + mconcat + [ "kind" .= String "VRFKeyHashAlreadyRegistered" + , "poolId" .= String (textShow poolId) + , "vrfKeyHash" .= String (textShow vrfKeyHash) + , "error" .= String "Pool with the same VRF Key Hash is already registered" + ] + +instance + Ledger.Crypto crypto => + LogFormatting (PrtclPredicateFailure crypto) + where + forMachine dtal (OverlayFailure f) = forMachine dtal f + forMachine dtal (UpdnFailure f) = forMachine dtal f + +instance + Ledger.Crypto crypto => + LogFormatting (OverlayPredicateFailure crypto) + where + forMachine _dtal (UnknownGenesisKeyOVERLAY (KeyHash genKeyHash)) = + mconcat + [ "kind" .= String "UnknownGenesisKeyOVERLAY" + , "unknownKeyHash" .= String (textShow genKeyHash) + ] + forMachine _dtal (VRFKeyBadLeaderValue seedNonce (SlotNo currSlotNo) prevHashNonce leaderElecVal) = + mconcat + [ "kind" .= String "VRFKeyBadLeaderValueOVERLAY" + , "seedNonce" .= String (textShow seedNonce) + , "currentSlot" .= String (textShow currSlotNo) + , "previousHashAsNonce" .= String (textShow prevHashNonce) + , "leaderElectionValue" .= String (textShow leaderElecVal) + ] + forMachine _dtal (VRFKeyBadNonce seedNonce (SlotNo currSlotNo) prevHashNonce blockNonce) = + mconcat + [ "kind" .= String "VRFKeyBadNonceOVERLAY" + , "seedNonce" .= String (textShow seedNonce) + , "currentSlot" .= String (textShow currSlotNo) + , "previousHashAsNonce" .= String (textShow prevHashNonce) + , "blockNonce" .= String (textShow blockNonce) + ] + forMachine _dtal (VRFKeyWrongVRFKey issuerHash regVRFKeyHash unregVRFKeyHash) = + mconcat + [ "kind" .= String "VRFKeyWrongVRFKeyOVERLAY" + , "poolHash" .= textShow issuerHash + , "registeredVRFKeHash" .= textShow regVRFKeyHash + , "unregisteredVRFKeyHash" .= textShow unregVRFKeyHash + ] + -- TODO: Pipe slot number with VRFKeyUnknown + forMachine _dtal (VRFKeyUnknown (KeyHash kHash)) = + mconcat + [ "kind" .= String "VRFKeyUnknownOVERLAY" + , "keyHash" .= String (textShow kHash) + ] + forMachine _dtal (VRFLeaderValueTooBig leadElecVal weightOfDelegPool actSlotCoefff) = + mconcat + [ "kind" .= String "VRFLeaderValueTooBigOVERLAY" + , "leaderElectionValue" .= String (textShow leadElecVal) + , "delegationPoolWeight" .= String (textShow weightOfDelegPool) + , "activeSlotCoefficient" .= String (textShow actSlotCoefff) + ] + forMachine _dtal (NotActiveSlotOVERLAY notActiveSlotNo) = + -- TODO: Elaborate on NotActiveSlot error + mconcat + [ "kind" .= String "NotActiveSlotOVERLAY" + , "slot" .= String (textShow notActiveSlotNo) + ] + forMachine _dtal (WrongGenesisColdKeyOVERLAY actual expected) = + mconcat + [ "kind" .= String "WrongGenesisColdKeyOVERLAY" + , "actual" .= actual + , "expected" .= expected + ] + forMachine _dtal (WrongGenesisVRFKeyOVERLAY issuer actual expected) = + mconcat + [ "kind" .= String "WrongGenesisVRFKeyOVERLAY" + , "issuer" .= issuer + , "actual" .= actual + , "expected" .= expected + ] + forMachine dtal (OcertFailure f) = forMachine dtal f + +instance LogFormatting OcertPredicateFailure where + forMachine _dtal (KESBeforeStartOCERT (KESPeriod oCertstart) (KESPeriod current)) = + mconcat + [ "kind" .= String "KESBeforeStartOCERT" + , "opCertKESStartPeriod" .= String (textShow oCertstart) + , "currentKESPeriod" .= String (textShow current) + , "error" + .= String + ( mconcat + [ "Your operational certificate's KES start period " + , "is before the KES current period." + ] + ) + ] + forMachine _dtal (KESAfterEndOCERT (KESPeriod current) (KESPeriod oCertstart) maxKESEvolutions) = + mconcat + [ "kind" .= String "KESAfterEndOCERT" + , "currentKESPeriod" .= String (textShow current) + , "opCertKESStartPeriod" .= String (textShow oCertstart) + , "maxKESEvolutions" .= String (textShow maxKESEvolutions) + , "error" + .= String + ( mconcat + [ "The operational certificate's KES start period is " + , "greater than the max number of KES + the KES current period" + ] + ) + ] + forMachine _dtal (CounterTooSmallOCERT lastKEScounterUsed currentKESCounter) = + mconcat + [ "kind" .= String "CounterTooSmallOCert" + , "currentKESCounter" .= String (textShow currentKESCounter) + , "lastKESCounter" .= String (textShow lastKEScounterUsed) + , "error" + .= String + ( mconcat + [ "The operational certificate's last KES counter is greater " + , "than the current KES counter." + ] + ) + ] + forMachine _dtal (InvalidSignatureOCERT oCertCounter oCertKESStartPeriod) = + mconcat + [ "kind" .= String "InvalidSignatureOCERT" + , "opCertKESStartPeriod" .= String (textShow oCertKESStartPeriod) + , "opCertCounter" .= String (textShow oCertCounter) + ] + forMachine _dtal (InvalidKesSignatureOCERT currKESPeriod startKESPeriod expectedKESEvolutions err) = + mconcat + [ "kind" .= String "InvalidKesSignatureOCERT" + , "opCertKESStartPeriod" .= String (textShow startKESPeriod) + , "opCertKESCurrentPeriod" .= String (textShow currKESPeriod) + , "opCertExpectedKESEvolutions" .= String (textShow expectedKESEvolutions) + , "error" .= err + ] + forMachine _dtal (NoCounterForKeyHashOCERT (KeyHash stakePoolKeyHash)) = + mconcat + [ "kind" .= String "NoCounterForKeyHashOCERT" + , "stakePoolKeyHash" .= String (textShow stakePoolKeyHash) + , "error" .= String "A counter was not found for this stake pool key hash" + ] + +instance LogFormatting (UpdnPredicateFailure crypto) where + forMachine _dtal x = case x of {} + +-- no constructors + +-------------------------------------------------------------------------------- +-- Alonzo related +-------------------------------------------------------------------------------- +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXOS" era)) + ) => + LogFormatting (AlonzoUtxoPredFailure era) + where + forMachine _dtal (Alonzo.BadInputsUTxO badInputs) = + mconcat + [ "kind" .= String "BadInputsUTxO" + , "badInputs" .= NonEmptySet.toSet badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) + ] + forMachine _dtal (Alonzo.OutsideValidityIntervalUTxO validtyInterval slot) = + mconcat + [ "kind" .= String "ExpiredUTxO" + , "validityInterval" .= validtyInterval + , "slot" .= slot + ] + forMachine _dtal (Alonzo.MaxTxSizeUTxO Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "MaxTxSizeUTxO" + , "size" .= mismatchSupplied + , "maxSize" .= mismatchExpected + ] + forMachine _dtal Alonzo.InputSetEmptyUTxO = + mconcat ["kind" .= String "InputSetEmptyUTxO"] + forMachine _dtal (Alonzo.FeeTooSmallUTxO Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "FeeTooSmallUTxO" + , "minimum" .= mismatchExpected + , "fee" .= mismatchSupplied + ] + forMachine _dtal (Alonzo.ValueNotConservedUTxO Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "ValueNotConservedUTxO" + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected + ] + forMachine _dtal (Alonzo.WrongNetwork network addrs) = + mconcat + [ "kind" .= String "WrongNetwork" + , "network" .= network + , "addrs" .= jsonNonEmptySet addrs + ] + forMachine _dtal (Alonzo.WrongNetworkWithdrawal network addrs) = + mconcat + [ "kind" .= String "WrongNetworkWithdrawal" + , "network" .= network + , "addrs" .= jsonNonEmptySet addrs + ] + forMachine _dtal (Alonzo.OutputTooSmallUTxO badOutputs) = + mconcat + [ "kind" .= String "OutputTooSmallUTxO" + , "outputs" .= badOutputs + , "error" + .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] + forMachine dtal (Alonzo.UtxosFailure predFailure) = + forMachine dtal predFailure + forMachine _dtal (Alonzo.OutputBootAddrAttrsTooBig txouts) = + mconcat + [ "kind" .= String "OutputBootAddrAttrsTooBig" + , "outputs" .= txouts + , "error" .= String "The Byron address attributes are too big" + ] + forMachine _dtal (Alonzo.OutputTooBigUTxO badOutputs) = + mconcat + [ "kind" .= String "OutputTooBigUTxO" + , "outputs" .= badOutputs + , "error" .= String "Too many asset ids in the tx output" + ] + forMachine _dtal (Alonzo.InsufficientCollateral computedBalance suppliedFee) = + mconcat + [ "kind" .= String "InsufficientCollateral" + , "balance" .= computedBalance + , "txfee" .= suppliedFee + ] + forMachine _dtal (Alonzo.ScriptsNotPaidUTxO utxos) = + mconcat + [ "kind" .= String "ScriptsNotPaidUTxO" + , "utxos" .= jsonNonEmptyMap utxos + ] + forMachine _dtal (Alonzo.ExUnitsTooBigUTxO Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "ExUnitsTooBigUTxO" + , "maxexunits" .= mismatchExpected + , "exunits" .= mismatchSupplied + ] + forMachine _dtal (Alonzo.CollateralContainsNonADA inputs) = + mconcat + [ "kind" .= String "CollateralContainsNonADA" + , "inputs" .= inputs + ] + forMachine _dtal (Alonzo.WrongNetworkInTxBody Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "WrongNetworkInTxBody" + , "networkid" .= mismatchExpected + , "txbodyNetworkId" .= mismatchSupplied + ] + forMachine _dtal (Alonzo.OutsideForecast slotNum) = + mconcat + [ "kind" .= String "OutsideForecast" + , "slot" .= slotNum + ] + forMachine _dtal (Alonzo.TooManyCollateralInputs Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "TooManyCollateralInputs" + , "max" .= mismatchExpected + , "inputs" .= mismatchSupplied + ] + forMachine _dtal Alonzo.NoCollateralInputs = + mconcat ["kind" .= String "NoCollateralInputs"] + +instance + ( ToJSON (Alonzo.CollectError ledgerera) + , LogFormatting (Ledger.EraRuleFailure "PPUP" ledgerera) + ) => + LogFormatting (AlonzoUtxosPredFailure ledgerera) + where + forMachine _ (Alonzo.ValidationTagMismatch isValidating reason) = + mconcat + [ "kind" .= String "ValidationTagMismatch" + , "isvalidating" .= isValidating + , "reason" .= reason + ] + forMachine _ (Alonzo.CollectErrors errors) = + mconcat + [ "kind" .= String "CollectErrors" + , "errors" .= errors + ] + forMachine dtal (Alonzo.UpdateFailure pFailure) = + forMachine dtal pFailure + +instance + ( Ledger.Era era + , Show (PredicateFailure (Ledger.EraRule "LEDGERS" era)) + ) => + LogFormatting (AlonzoBbodyPredFailure era) + where + forMachine _ err = + mconcat + [ "kind" .= String "AlonzoBbodyPredFail" + , "error" .= String (textShow err) + ] + +-------------------------------------------------------------------------------- +-- Babbage related +-------------------------------------------------------------------------------- + +instance + ( Ledger.Era era + , LogFormatting (AlonzoUtxoPredFailure era) + , ToJSON (Ledger.TxOut era) + ) => + LogFormatting (BabbageUtxoPredFailure era) + where + forMachine v err = + case err of + Babbage.AlonzoInBabbageUtxoPredFailure alonzoFail -> + forMachine v alonzoFail + Babbage.IncorrectTotalCollateralField provided declared -> + mconcat + [ "kind" .= String "IncorrectTotalCollateralField" + , "collateralProvided" .= provided + , "collateralDeclared" .= declared + ] + -- The transaction contains outputs that are too small + Babbage.BabbageOutputTooSmallUTxO outputs -> + mconcat + [ "kind" .= String "OutputTooSmall" + , "outputs" .= outputs + ] + Babbage.BabbageNonDisjointRefInputs nonDisjointInputs -> + mconcat + [ "kind" .= String "BabbageNonDisjointRefInputs" + , "outputs" .= nonDisjointInputs + ] + +instance + ( AnyEraScript ledgerera + , Ledger.Era ledgerera + , ShelleyBasedEra ledgerera + , LogFormatting (Ledger.EraRuleFailure "PPUP" ledgerera) + , LogFormatting (ShelleyUtxowPredFailure ledgerera) + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" ledgerera)) + ) => + LogFormatting (BabbageUtxowPredFailure ledgerera) + where + forMachine v err = + case err of + Babbage.AlonzoInBabbageUtxowPredFailure alonzoFail -> + forMachine v alonzoFail + Babbage.UtxoFailure utxoFail -> + forMachine v utxoFail + -- TODO: Plutus team needs to expose a better error type. + Babbage.MalformedScriptWitnesses s -> + mconcat + [ "kind" .= String "MalformedScriptWitnesses" + , "scripts" .= jsonNonEmptySet s + ] + Babbage.MalformedReferenceScripts s -> + mconcat + [ "kind" .= String "MalformedReferenceScripts" + , "scripts" .= jsonNonEmptySet s + ] + Babbage.ScriptIntegrityHashMismatch Mismatch{mismatchSupplied, mismatchExpected} mBytes -> + mconcat + [ "kind" .= String "ScriptIntegrityHashMismatch" + , "supplied" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) + , "expected" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) + , "hashHexPreimage" .= formatAsHex (strictMaybeToMaybe mBytes) + ] + +-------------------------------------------------------------------------------- +-- Conway related +-------------------------------------------------------------------------------- + +instance + ( Ledger.Era era + , Show (PredicateFailure (Ledger.EraRule "LEDGERS" era)) + ) => + LogFormatting (Conway.ConwayBbodyPredFailure era) + where + forMachine _ err = + mconcat + [ "kind" .= String "ConwayBbodyPredFail" + , "error" .= String (textShow err) + ] + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXOW" era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "GOV" era)) + , LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" era)) + ) => + LogFormatting (Conway.ConwayLedgerPredFailure era) + where + forMachine v (Conway.ConwayUtxowFailure f) = forMachine v f + forMachine _ (Conway.ConwayWithdrawalsMissingAccounts missingWithdrawals) = + mconcat + [ "kind" .= String "ConwayWithdrawalsMissingAccounts" + , "withdrawals" .= unWithdrawals missingWithdrawals + ] + forMachine _ (Conway.ConwayIncompleteWithdrawals incompleteWithdrawals) = + mconcat + [ "kind" .= String "ConwayIncompleteWithdrawals" + , "withdrawals" .= renderIncompleteWithdrawals incompleteWithdrawals + ] + forMachine _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" + , "actual" .= mismatchSupplied + , "limit" .= mismatchExpected + ] + forMachine v (Conway.ConwayCertsFailure f) = forMachine v f + forMachine v (Conway.ConwayGovFailure f) = forMachine v f + forMachine v (Conway.ConwayWdrlNotDelegatedToDRep f) = forMachine v f + forMachine _ (Conway.ConwayTreasuryValueMismatch Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "ConwayTreasuryValueMismatch" + , "actual" .= mismatchExpected + , "submittedInTx" .= mismatchSupplied + ] + forMachine _ (Conway.ConwayMempoolFailure message) = + mconcat + [ "kind" .= String "ConwayMempoolFailure" + , "actual" .= message + ] + +instance + Consensus.ShelleyBasedEra era => + LogFormatting (Conway.ConwayGovPredFailure era) + where + forMachine _ (Conway.GovActionsDoNotExist govActionIds) = + mconcat + [ "kind" .= String "GovActionsDoNotExist" + , "govActionId" .= map govActionIdToText (NonEmpty.toList govActionIds) + ] + forMachine _ (Conway.MalformedProposal govAction) = + mconcat + [ "kind" .= String "MalformedProposal" + , "govAction" .= govAction + ] + forMachine _ (Conway.ProposalProcedureNetworkIdMismatch rewardAcnt network) = + mconcat + [ "kind" .= String "ProposalProcedureNetworkIdMismatch" + , "rewardAccount" .= toJSON rewardAcnt + , "expectedNetworkId" .= toJSON network + ] + forMachine _ (Conway.TreasuryWithdrawalsNetworkIdMismatch rewardAcnts network) = + mconcat + [ "kind" .= String "TreasuryWithdrawalsNetworkIdMismatch" + , "rewardAccounts" .= jsonNonEmptySet rewardAcnts + , "expectedNetworkId" .= toJSON network + ] + forMachine _ (Conway.ProposalDepositIncorrect Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "ProposalDepositIncorrect" + , "deposit" .= mismatchSupplied + , "expectedDeposit" .= mismatchExpected + ] + forMachine _ (Conway.DisallowedVoters govActionIdToVoter) = + mconcat + [ "kind" .= String "DisallowedVoters" + , "govActionIdToVoter" .= NonEmpty.toList govActionIdToVoter + ] + forMachine _ (Conway.VotersDoNotExist creds) = + mconcat + [ "kind" .= String "VotersDoNotExist" + , "credentials" .= NonEmpty.toList creds + ] + forMachine _ (Conway.ConflictingCommitteeUpdate creds) = + mconcat + [ "kind" .= String "ConflictingCommitteeUpdate" + , "credentials" .= jsonNonEmptySet creds + ] + forMachine _ (Conway.ExpirationEpochTooSmall credsToEpoch) = + mconcat + [ "kind" .= String "ExpirationEpochTooSmall" + , "credentialsToEpoch" .= jsonNonEmptyMap credsToEpoch + ] + forMachine _ (Conway.InvalidPrevGovActionId proposalProcedure) = + mconcat + [ "kind" .= String "InvalidPrevGovActionId" + , "proposalProcedure" .= proposalProcedure + ] + forMachine _ (Conway.VotingOnExpiredGovAction actions) = + mconcat + [ "kind" .= String "VotingOnExpiredGovAction" + , "action" .= actions + ] + forMachine _ (Conway.ProposalCantFollow prevGovActionId Mismatch{mismatchSupplied, mismatchExpected}) = + mconcat + [ "kind" .= String "ProposalCantFollow" + , "prevGovActionId" .= prevGovActionId + , "protVer" .= mismatchSupplied + , "prevProtVer" .= mismatchExpected + ] + forMachine _ (Conway.DisallowedProposalDuringBootstrap proposal) = + mconcat + [ "kind" .= String "DisallowedProposalDuringBootstrap" + , "proposal" .= proposal + ] + forMachine _ (Conway.DisallowedVotesDuringBootstrap votes) = + mconcat + [ "kind" .= String "DisallowedVotesDuringBootstrap" + , "votes" .= votes + ] + forMachine _ (Conway.ZeroTreasuryWithdrawals govAction) = + mconcat + [ "kind" .= String "ZeroTreasuryWithdrawals" + , "govAction" .= govAction + ] + forMachine _ (Conway.ProposalReturnAccountDoesNotExist account) = + mconcat + [ "kind" .= String "ProposalReturnAccountDoesNotExist" + , "invalidAccount" .= account + ] + forMachine _ (Conway.TreasuryWithdrawalReturnAccountsDoNotExist accounts) = + mconcat + [ "kind" .= String "TreasuryWithdrawalReturnAccountsDoNotExist" + , "invalidAccounts" .= accounts + ] + forMachine _ (Conway.UnelectedCommitteeVoters voters) = + mconcat + [ "kind" .= String "UnelectedCommitteeVoters" + , "unelectedCommitteeVoters" .= voters + ] + forMachine _ (Conway.InvalidGuardrailsScriptHash actualPolicyHash expectedPolicyHash) = + mconcat + [ "kind" .= String "InvalidPolicyHash" + , "actualPolicyHash" .= actualPolicyHash + , "expectedPolicyHash" .= expectedPolicyHash + ] + +instance + ( Consensus.ShelleyBasedEra era + , LogFormatting (PredicateFailure (Ledger.EraRule "CERT" era)) + ) => + LogFormatting (Conway.ConwayCertsPredFailure era) + where + forMachine dtal (Conway.CertFailure certFailure) = + forMachine dtal certFailure + +instance + ( LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXOW" ledgerera)) + , LogFormatting (PredicateFailure (Ledger.EraRule "GOV" ledgerera)) + ) => + LogFormatting (Dijkstra.DijkstraLedgerPredFailure ledgerera) + where + forMachine _ = error "Dijkstra era is not active yet" + +instance + LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) => + LogFormatting (Dijkstra.DijkstraGovCertPredFailure ledgerera) + where + forMachine _ = error "Dijkstra era is not active yet" + +instance + LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) => + LogFormatting (Dijkstra.DijkstraGovPredFailure ledgerera) + where + forMachine _ = error "Dijkstra era is not active yet" + +instance + LogFormatting (PredicateFailure (Ledger.EraRule "UTXOW" ledgerera)) => + LogFormatting (Dijkstra.DijkstraUtxowPredFailure ledgerera) + where + forMachine _ = error "Dijkstra era is not active yet" + +instance + LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) => + LogFormatting (Dijkstra.DijkstraBbodyPredFailure ledgerera) + where + forMachine _ = error "Dijkstra era is not active yet" + +instance + LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) => + LogFormatting (Dijkstra.DijkstraUtxoPredFailure ledgerera) + where + forMachine _ = error "Dijkstra era is not active yet" + +instance + Ledger.Crypto crypto => + LogFormatting (Praos.PraosValidationErr crypto) + where + forMachine _ err' = + case err' of + Praos.VRFKeyUnknown unknownKeyHash -> + mconcat + [ "kind" .= String "VRFKeyUnknown" + , "vrfKey" .= unknownKeyHash + ] + Praos.VRFKeyWrongVRFKey stakePoolKeyHash registeredVrfForSaidStakepool wrongKeyHashInBlockHeader -> + mconcat + [ "kind" .= String "VRFKeyWrongVRFKey" + , "stakePoolKeyHash" .= stakePoolKeyHash + , "stakePoolVrfKey" .= registeredVrfForSaidStakepool + , "blockHeaderVrfKey" .= wrongKeyHashInBlockHeader + ] + Praos.VRFKeyBadProof slotNo nonce vrfCalculatedVal -> + mconcat + [ "kind" .= String "VRFKeyBadProof" + , "slotNumberUsedInVrfCalculation" .= slotNo + , "nonceUsedInVrfCalculation" .= nonce + , "calculatedVrfValue" .= String (textShow vrfCalculatedVal) + ] + Praos.VRFLeaderValueTooBig leaderValue sigma f -> + mconcat + [ "kind" .= String "VRFLeaderValueTooBig" + , "leaderValue" .= leaderValue + , "sigma" .= sigma + , "f" .= activeSlotLog f + ] + Praos.KESBeforeStartOCERT startKesPeriod currKesPeriod -> + mconcat + [ "kind" .= String "KESBeforeStartOCERT" + , "opCertStartingKesPeriod" .= kesPeriodValue startKesPeriod + , "currentKesPeriod" .= kesPeriodValue currKesPeriod + ] + Praos.KESAfterEndOCERT currKesPeriod startKesPeriod maxKesKeyEvos -> + mconcat + [ "kind" .= String "KESAfterEndOCERT" + , "opCertStartingKesPeriod" .= kesPeriodValue startKesPeriod + , "currentKesPeriod" .= kesPeriodValue currKesPeriod + , "maxKesKeyEvolutions" .= maxKesKeyEvos + ] + Praos.CounterTooSmallOCERT lastCounter currentCounter -> + mconcat + [ "kind" .= String "CounterTooSmallOCERT" + , "lastCounter" .= lastCounter + , "currentCounter" .= currentCounter + ] + Praos.CounterOverIncrementedOCERT lastCounter currentCounter -> + mconcat + [ "kind" .= String "CounterOverIncrementedOCERT" + , "lastCounter" .= lastCounter + , "currentCounter" .= currentCounter + ] + Praos.InvalidSignatureOCERT counter oCertStartKesPeriod err -> + mconcat + [ "kind" .= String "InvalidSignatureOCERT" + , "counter" .= counter + , "opCertStartingKesPeriod" .= kesPeriodValue oCertStartKesPeriod + , "error" .= err + ] + Praos.InvalidKesSignatureOCERT currentKesPeriod opCertStartKesPeriod expectedKesEvos maxKesEvos err -> + mconcat + [ "kind" .= String "InvalidKesSignatureOCERT" + , "currentKesPeriod" .= currentKesPeriod + , "opCertStartingKesPeriod" .= opCertStartKesPeriod + , "expectedKesEvolutions" .= expectedKesEvos + , "maximumKesEvos" .= maxKesEvos + , "error" .= err + ] + Praos.NoCounterForKeyHashOCERT stakePoolKeyHash -> + mconcat + [ "kind" .= String "NoCounterForKeyHashOCERT" + , "stakePoolKeyHash" .= stakePoolKeyHash + ] + +instance LogFormatting (Praos.PraosCannotForge crypto) where + forMachine _ (Praos.PraosCannotForgeKeyNotUsableYet currentKesPeriod startingKesPeriod) = + mconcat + [ "kind" .= String "PraosCannotForgeKeyNotUsableYet" + , "currentKesPeriod" .= kesPeriodValue currentKesPeriod + , "opCertStartingKesPeriod" .= kesPeriodValue startingKesPeriod + ] + +instance LogFormatting Praos.EnvelopeError where + forMachine _ err' = + case err' of + Praos.ObsoleteNode maxPtclVersionFromPparams blkHeaderPtclVersion -> + mconcat + [ "kind" .= String "ObsoleteNode" + , "maxMajorProtocolVersion" .= maxPtclVersionFromPparams + , "headerProtocolVersion" .= blkHeaderPtclVersion + ] + Praos.HeaderSizeTooLarge headerSize ledgerViewMaxHeaderSize -> + mconcat + [ "kind" .= String "HeaderSizeTooLarge" + , "maxHeaderSize" .= ledgerViewMaxHeaderSize + , "headerSize" .= headerSize + ] + Praos.BlockSizeTooLarge blockSize ledgerViewMaxBlockSize -> + mconcat + [ "kind" .= String "BlockSizeTooLarge" + , "maxBlockSize" .= ledgerViewMaxBlockSize + , "blockSize" .= blockSize + ] + +instance + ToJSON (Alonzo.CollectError ledgerera) => + LogFormatting (Conway.ConwayUtxosPredFailure ledgerera) + where + forMachine _ (Conway.ValidationTagMismatch isValidating reason) = + mconcat + [ "kind" .= String "ValidationTagMismatch" + , "isvalidating" .= isValidating + , "reason" .= reason + ] + forMachine _ (Conway.CollectErrors errors) = + mconcat + [ "kind" .= String "CollectErrors" + , "errors" .= errors + ] + +-- We define this bogus instance as it is required by some of the +-- 'LogFormatting' instances in this module +instance LogFormatting (Ledger.VoidEraRule rule era) where + -- NOTE: There are no values of type 'Ledger.VoidEraRule rule era' + forMachine _ = \case {} + +instance + ( AnyEraScript ledgerera + , Consensus.ShelleyBasedEra ledgerera + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXOS" ledgerera)) + ) => + LogFormatting (Conway.ConwayUtxoPredFailure ledgerera) + where + forMachine dtal = \case + Conway.UtxosFailure utxosPredFailure -> forMachine dtal utxosPredFailure + Conway.BadInputsUTxO badInputs -> + mconcat + [ "kind" .= String "BadInputsUTxO" + , "badInputs" .= NonEmptySet.toSet badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) + ] + Conway.OutsideValidityIntervalUTxO validityInterval slot -> + mconcat + [ "kind" .= String "ExpiredUTxO" + , "validityInterval" .= validityInterval + , "slot" .= slot + ] + Conway.MaxTxSizeUTxO Mismatch{mismatchSupplied, mismatchExpected} -> + mconcat + [ "kind" .= String "MaxTxSizeUTxO" + , "size" .= mismatchSupplied + , "maxSize" .= mismatchExpected + ] + Conway.InputSetEmptyUTxO -> + mconcat ["kind" .= String "InputSetEmptyUTxO"] + Conway.FeeTooSmallUTxO Mismatch{mismatchSupplied, mismatchExpected} -> + mconcat + [ "kind" .= String "FeeTooSmallUTxO" + , "minimum" .= mismatchExpected + , "fee" .= mismatchSupplied + ] + Conway.ValueNotConservedUTxO Mismatch{mismatchSupplied, mismatchExpected} -> + mconcat + [ "kind" .= String "ValueNotConservedUTxO" + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected + ] + Conway.WrongNetwork network addrs -> + mconcat + [ "kind" .= String "WrongNetwork" + , "network" .= network + , "addrs" .= jsonNonEmptySet addrs + ] + Conway.WrongNetworkWithdrawal network addrs -> + mconcat + [ "kind" .= String "WrongNetworkWithdrawal" + , "network" .= network + , "addrs" .= jsonNonEmptySet addrs + ] + Conway.OutputTooSmallUTxO badOutputs -> + mconcat + [ "kind" .= String "OutputTooSmallUTxO" + , "outputs" .= badOutputs + , "error" + .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] + Conway.OutputBootAddrAttrsTooBig badOutputs -> + mconcat + [ "kind" .= String "OutputBootAddrAttrsTooBig" + , "outputs" .= badOutputs + , "error" .= String "The Byron address attributes are too big" + ] + Conway.OutputTooBigUTxO badOutputs -> + mconcat + [ "kind" .= String "OutputTooBigUTxO" + , "outputs" .= badOutputs + , "error" .= String "Too many asset ids in the tx output" + ] + Conway.InsufficientCollateral computedBalance suppliedFee -> + mconcat + [ "kind" .= String "InsufficientCollateral" + , "balance" .= computedBalance + , "txfee" .= suppliedFee + ] + Conway.ScriptsNotPaidUTxO utxos -> + mconcat + [ "kind" .= String "ScriptsNotPaidUTxO" + , "utxos" .= jsonNonEmptyMap utxos + ] + Conway.ExUnitsTooBigUTxO Mismatch{mismatchSupplied, mismatchExpected} -> + mconcat + [ "kind" .= String "ExUnitsTooBigUTxO" + , "maxexunits" .= mismatchExpected + , "exunits" .= mismatchSupplied + ] + Conway.CollateralContainsNonADA inputs -> + mconcat + [ "kind" .= String "CollateralContainsNonADA" + , "inputs" .= inputs + ] + Conway.WrongNetworkInTxBody Mismatch{mismatchSupplied, mismatchExpected} -> + mconcat + [ "kind" .= String "WrongNetworkInTxBody" + , "networkid" .= mismatchExpected + , "txbodyNetworkId" .= mismatchSupplied + ] + Conway.OutsideForecast slotNum -> + mconcat + [ "kind" .= String "OutsideForecast" + , "slot" .= slotNum + ] + Conway.TooManyCollateralInputs Mismatch{mismatchSupplied, mismatchExpected} -> + mconcat + [ "kind" .= String "TooManyCollateralInputs" + , "max" .= mismatchExpected + , "inputs" .= mismatchSupplied + ] + Conway.NoCollateralInputs -> + mconcat ["kind" .= String "NoCollateralInputs"] + Conway.IncorrectTotalCollateralField provided declared -> + mconcat + [ "kind" .= String "UnequalCollateralReturn" + , "collateralProvided" .= provided + , "collateralDeclared" .= declared + ] + Conway.BabbageOutputTooSmallUTxO outputs -> + mconcat + [ "kind" .= String "BabbageOutputTooSmall" + , "outputs" .= outputs + ] + Conway.BabbageNonDisjointRefInputs nonDisjointInputs -> + mconcat + [ "kind" .= String "BabbageNonDisjointRefInputs" + , "outputs" .= nonDisjointInputs + ] + +instance + ( AnyEraScript ledgerera + , Consensus.ShelleyBasedEra ledgerera + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" ledgerera)) + ) => + LogFormatting (Conway.ConwayUtxowPredFailure ledgerera) + where + forMachine dtal = \case + Conway.UtxoFailure utxoPredFail -> forMachine dtal utxoPredFail + Conway.InvalidWitnessesUTXOW ws -> + mconcat + [ "kind" .= String "InvalidWitnessesUTXOW" + , "invalidWitnesses" .= map textShow (NonEmpty.toList ws) + ] + Conway.MissingVKeyWitnessesUTXOW ws -> + mconcat + [ "kind" .= String "MissingVKeyWitnessesUTXOW" + , "missingWitnesses" .= jsonNonEmptySet ws + ] + Conway.MissingScriptWitnessesUTXOW scripts -> + mconcat + [ "kind" .= String "MissingScriptWitnessesUTXOW" + , "missingScripts" .= jsonNonEmptySet scripts + ] + Conway.ScriptWitnessNotValidatingUTXOW failedScripts -> + mconcat + [ "kind" .= String "ScriptWitnessNotValidatingUTXOW" + , "failedScripts" .= jsonNonEmptySet failedScripts + ] + Conway.MissingTxBodyMetadataHash hash -> + mconcat + [ "kind" .= String "MissingTxMetadata" + , "txBodyMetadataHash" .= hash + ] + Conway.MissingTxMetadata hash -> + mconcat + [ "kind" .= String "MissingTxMetadata" + , "txBodyMetadataHash" .= hash + ] + Conway.ConflictingMetadataHash Mismatch{mismatchSupplied, mismatchExpected} -> + mconcat + [ "kind" .= String "ConflictingMetadataHash" + , "txBodyMetadataHash" .= mismatchSupplied + , "fullMetadataHash" .= mismatchExpected + ] + Conway.InvalidMetadata -> + mconcat + [ "kind" .= String "InvalidMetadata" + ] + Conway.ExtraneousScriptWitnessesUTXOW scripts -> + mconcat + [ "kind" .= String "InvalidWitnessesUTXOW" + , "extraneousScripts" .= Set.map renderScriptHash (NonEmptySet.toSet scripts) + ] + Conway.MissingRedeemers scripts -> + mconcat + [ "kind" .= String "MissingRedeemers" + , "scripts" .= renderMissingRedeemers scripts + ] + Conway.MissingRequiredDatums required received -> + mconcat + [ "kind" .= String "MissingRequiredDatums" + , "required" + .= map + (Crypto.hashToTextAsHex . Hashes.extractHash) + (NonEmptySet.toList required) + , "received" + .= map + (Crypto.hashToTextAsHex . Hashes.extractHash) + (Set.toList received) + ] + Conway.NotAllowedSupplementalDatums disallowed acceptable -> + mconcat + [ "kind" .= String "NotAllowedSupplementalDatums" + , "disallowed" .= NonEmptySet.toList disallowed + , "acceptable" .= Set.toList acceptable + ] + Conway.PPViewHashesDontMatch Mismatch{mismatchSupplied, mismatchExpected} -> + mconcat + [ "kind" .= String "PPViewHashesDontMatch" + , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) + , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) + ] + Conway.UnspendableUTxONoDatumHash ins -> + mconcat + [ "kind" .= String "MissingRequiredSigners" + , "txins" .= NonEmptySet.toList ins + ] + Conway.ExtraRedeemers rs -> + mconcat + [ "kind" .= String "ExtraRedeemers" + , "rdmrs" .= map renderScriptIndex (NonEmpty.toList rs) + ] + Conway.MalformedScriptWitnesses scripts -> + mconcat + [ "kind" .= String "MalformedScriptWitnesses" + , "scripts" .= jsonNonEmptySet scripts + ] + Conway.MalformedReferenceScripts scripts -> + mconcat + [ "kind" .= String "MalformedReferenceScripts" + , "scripts" .= jsonNonEmptySet scripts + ] + Conway.ScriptIntegrityHashMismatch Mismatch{mismatchSupplied, mismatchExpected} mBytes -> + mconcat + [ "kind" .= String "ScriptIntegrityHashMismatch" + , "supplied" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) + , "expected" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) + , "hashHexPreimage" .= formatAsHex (strictMaybeToMaybe mBytes) + ] + +instance LogFormatting (Praos.PraosTiebreakerView crypto) where + forMachine + _dtal + Praos.PraosTiebreakerView + { ptvSlotNo + , ptvIssuer + , ptvIssueNo + , ptvTieBreakVRF + } = + mconcat + [ "kind" .= String "PraosTiebreakerView" + , "slotNo" .= ptvSlotNo + , "issuerHash" .= hashKey ptvIssuer + , "issueNo" .= ptvIssueNo + , "tieBreakVRF" .= renderVRF ptvTieBreakVRF + ] + where + renderVRF = Text.Encoding.decodeUtf8 . B16.encode . Crypto.getOutputVRFBytes + +-------------------------------------------------------------------------------- +-- Helper functions +-------------------------------------------------------------------------------- + +showLastAppBlockNo :: WithOrigin LastAppliedBlock -> Text +showLastAppBlockNo wOblk = case withOriginToMaybe wOblk of + Nothing -> "Genesis Block" + Just blk -> textShow . unBlockNo $ labBlockNo blk diff --git a/tracing/Ouroboros/Consensus/Tracing/Era/Shelley/Render.hs b/tracing/Ouroboros/Consensus/Tracing/Era/Shelley/Render.hs new file mode 100644 index 0000000000..3cf1166c80 --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/Era/Shelley/Render.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | JSON rendering helpers for Shelley-era ledger types used by the tracing +-- instances in "Ouroboros.Consensus.Tracing.Era.Shelley". +-- +-- These were originally in @cardano-node@'s @Cardano.Node.Tracing.Render@ and +-- went through @cardano-api@. They are reimplemented here directly against +-- @cardano-ledger@ (so Consensus need not depend on @cardano-api@, which sits +-- downstream), reproducing @cardano-api@'s output: bech32 stake/reward +-- addresses (CIP-19), hex script hashes, and era-generic plutus purposes. +module Ouroboros.Consensus.Tracing.Era.Shelley.Render + ( renderScriptHash + , renderScriptIntegrityHash + , renderScriptPurpose + , renderScriptIndex + , renderMissingRedeemers + , renderIncompleteWithdrawals + , renderRewardAccount + , renderTxIn + ) where + +import qualified Cardano.Crypto.Hash.Class as Crypto +import Cardano.Ledger.Address (AccountAddress (..), serialiseAccountAddress) +import Cardano.Ledger.Alonzo.Scripts (AsItem (..), AsIx (..)) +import qualified Cardano.Ledger.Alonzo.Tx as Alonzo +import Cardano.Ledger.Api.Scripts + ( AnyEraScript + , PlutusPurpose + , pattern AnyEraCertifyingPurpose + , pattern AnyEraGuardingPurpose + , pattern AnyEraMintingPurpose + , pattern AnyEraProposingPurpose + , pattern AnyEraSpendingPurpose + , pattern AnyEraVotingPurpose + , pattern AnyEraWithdrawingPurpose + ) +import Cardano.Ledger.BaseTypes + ( Mismatch (..) + , Network (..) + , Relation (..) + , TxIx (..) + ) +import Cardano.Ledger.Conway.Governance (ProposalProcedure) +import qualified Cardano.Ledger.Core as Ledger +import Cardano.Ledger.Hashes (ScriptHash (..)) +import qualified Cardano.Ledger.Hashes as Hashes +import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) +import qualified Codec.Binary.Bech32 as Bech32 +import Data.Aeson (ToJSON, Value, toJSON, (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Aeson +import qualified Data.ByteString.Base16 as B16 +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.NonEmpty (NonEmptyMap) +import qualified Data.Map.NonEmpty as NonEmptyMap +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import Data.Word (Word32) + +-- | Hex-encode a script hash, matching @cardano-api@'s +-- @serialiseToRawBytesHexText . fromShelleyScriptHash@. +renderScriptHash :: ScriptHash -> Text +renderScriptHash (ScriptHash h) = Crypto.hashToTextAsHex h + +renderScriptIntegrityHash :: Maybe Alonzo.ScriptIntegrityHash -> Value +renderScriptIntegrityHash (Just witPPDataHash) = + Aeson.String . Crypto.hashToTextAsHex $ Hashes.extractHash witPPDataHash +renderScriptIntegrityHash Nothing = Aeson.Null + +-- | Bech32-encode a reward/stake account address (CIP-19), matching +-- @cardano-api@'s @serialiseAddress . fromShelleyStakeAddr@: human-readable +-- part @stake@ on mainnet, @stake_test@ on testnets. +renderRewardAccount :: AccountAddress -> Text +renderRewardAccount acct = + case Bech32.encode hrp (Bech32.dataPartFromBytes bytes) of + Right t -> t + -- 'encode' only fails if the payload exceeds bech32 length limits, which + -- a 29-byte stake address never does; fall back to hex just in case. + Left _ -> Text.Encoding.decodeLatin1 (B16.encode bytes) + where + bytes = serialiseAccountAddress acct + hrp = case aaNetworkId acct of + Mainnet -> hrpStake + Testnet -> hrpStakeTest + +hrpStake, hrpStakeTest :: Bech32.HumanReadablePart +hrpStake = unsafeHrp "stake" +hrpStakeTest = unsafeHrp "stake_test" + +-- | These literals are valid human-readable parts, so this never fails. +unsafeHrp :: Text -> Bech32.HumanReadablePart +unsafeHrp t = case Bech32.humanReadablePartFromText t of + Right hrp -> hrp + Left err -> error ("renderRewardAccount: invalid HRP " <> show t <> ": " <> show err) + +-- | Render a transaction input as @\#\@. +-- +-- Deliberately not @cardano-ledger@'s @ToJSON TxIn@: that one shows the index +-- newtype, giving @...#TxIx {unTxIx = 0}@. @cardano-api@ rendered the bare +-- number, and that is what the log has always carried. +renderTxIn :: TxIn -> Text +renderTxIn (TxIn (TxId h) (TxIx ix)) = + Crypto.hashToTextAsHex (Hashes.extractHash h) <> "#" <> Text.pack (show ix) + +-- | Render a plutus script purpose (as an item), era-generically via +-- @cardano-ledger-api@'s @AnyEraScript@ projections. Replaces @cardano-api@'s +-- per-era @renderAlonzoPlutusPurpose@/@renderConwayPlutusPurpose@. +-- +-- The projections are pattern synonyms, but @cardano-ledger-api@ ships a +-- @COMPLETE@ pragma covering all seven of them, so GHC does check exhaustiveness +-- here. Matching all seven rather than falling through to a catch-all means the +-- next ledger era shows up as a warning at compile time instead of as an +-- unrenderable purpose in an operator's logs. +renderScriptPurpose :: + ( AnyEraScript era + , ToJSON (Ledger.TxCert era) + , ToJSON (ProposalProcedure era) + ) => + PlutusPurpose AsItem era -> + Value +-- Note the asymmetry in whether the 'AsItem' wrapper is unwrapped: spending, +-- rewarding and guarding render their item directly, the other four go through +-- @ToJSON (AsItem ix it)@ and so come out wrapped in an @{"item": ...}@ object. +-- That is what @cardano-api@'s renderer did for the six purposes it knew about, +-- so it is what consumers parse; changing it is a deliberate format change, not +-- a cleanup to make here. Guarding is new in Dijkstra and has no @cardano-api@ +-- rendering to preserve, so it renders directly, like the other two purposes +-- for which we have a dedicated renderer. +renderScriptPurpose = \case + AnyEraSpendingPurpose (AsItem txin) -> + Aeson.object ["spending" .= Aeson.String (renderTxIn txin)] + AnyEraMintingPurpose pid -> + Aeson.object ["minting" .= toJSON pid] + AnyEraWithdrawingPurpose (AsItem rwdAcct) -> + Aeson.object ["rewarding" .= Aeson.String (renderRewardAccount rwdAcct)] + AnyEraCertifyingPurpose cert -> + Aeson.object ["certifying" .= toJSON cert] + AnyEraVotingPurpose voter -> + Aeson.object ["voting" .= toJSON voter] + AnyEraProposingPurpose proposal -> + Aeson.object ["proposing" .= toJSON proposal] + AnyEraGuardingPurpose (AsItem sHash) -> + Aeson.object ["guarding" .= Aeson.String (renderScriptHash sHash)] + +-- | Render a plutus script purpose given by its index (redeemer pointer), +-- era-generically. +-- +-- Reproduces what @cardano-api@'s @toScriptIndex@ followed by +-- @ToJSON ScriptWitnessIndex@ emitted: a @kind@ naming the witness index +-- constructor and the index itself under @value@. The constructor names are +-- @cardano-api@'s and do not all match the purpose names used by +-- 'renderScriptPurpose' above. @ScriptWitnessIndexGuarding@ is the exception: +-- @cardano-api@ has no constructor for the Dijkstra-era guarding purpose, so +-- that name is ours, following the same scheme. +renderScriptIndex :: AnyEraScript era => PlutusPurpose AsIx era -> Value +renderScriptIndex = \case + AnyEraSpendingPurpose (AsIx ix) -> witnessIndex "ScriptWitnessIndexTxIn" ix + AnyEraMintingPurpose (AsIx ix) -> witnessIndex "ScriptWitnessIndexMint" ix + AnyEraWithdrawingPurpose (AsIx ix) -> witnessIndex "ScriptWitnessIndexWithdrawal" ix + AnyEraCertifyingPurpose (AsIx ix) -> witnessIndex "ScriptWitnessIndexCertificate" ix + AnyEraVotingPurpose (AsIx ix) -> witnessIndex "ScriptWitnessIndexVoting" ix + AnyEraProposingPurpose (AsIx ix) -> witnessIndex "ScriptWitnessIndexProposing" ix + AnyEraGuardingPurpose (AsIx ix) -> witnessIndex "ScriptWitnessIndexGuarding" ix + where + witnessIndex :: Text -> Word32 -> Value + witnessIndex kind ix = Aeson.object ["kind" .= kind, "value" .= ix] + +renderMissingRedeemers :: + ( AnyEraScript era + , Ledger.EraPParams era + , ToJSON (Ledger.TxCert era) + ) => + NonEmpty (PlutusPurpose AsItem era, ScriptHash) -> + Value +renderMissingRedeemers scripts = + Aeson.object $ NonEmpty.toList $ NonEmpty.map renderTuple scripts + where + renderTuple (scriptPurpose, sHash) = + Aeson.fromText (renderScriptHash sHash) .= renderScriptPurpose scriptPurpose + +renderIncompleteWithdrawals :: + Show payload => + NonEmptyMap AccountAddress (Mismatch RelEQ payload) -> + Value +renderIncompleteWithdrawals payload = + Aeson.object $ map renderTuple $ NonEmptyMap.toList payload + where + renderTuple (address, mismatch) = + Aeson.fromText (renderRewardAccount address) .= show mismatch diff --git a/tracing/Ouroboros/Consensus/Tracing/Formatting.hs b/tracing/Ouroboros/Consensus/Tracing/Formatting.hs new file mode 100644 index 0000000000..5c16d7433f --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/Formatting.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ouroboros.Consensus.Tracing.Formatting + ( + ) where + +import Cardano.Logging (LogFormatting (..)) +import Data.Aeson (Value (String), toJSON, (.=)) +import Data.Proxy (Proxy (..)) +import Data.Void (Void) +import Ouroboros.Consensus.Block + ( ConvertRawHash (..) + , Header + , RealPoint + , realPointHash + , realPointSlot + ) +import Ouroboros.Consensus.Tracing.Render +import qualified Ouroboros.Network.AnchoredFragment as AF +import Ouroboros.Network.Block + +-- | Derives ConvertRawHash for Header blk from ConvertRawHash blk. +-- Safe because HeaderHash (Header blk) = HeaderHash blk. +instance ConvertRawHash blk => ConvertRawHash (Header blk) where + type HashSize (Header blk) = HashSize blk + toShortRawHash _ = toShortRawHash (Proxy @blk) + unsafeFromShortRawHash _ = unsafeFromShortRawHash (Proxy @blk) + +-- | A bit of a weird one, but needed because some of the very general +-- consensus interfaces are sometimes instantiated to 'Void', when there are +-- no cases needed. +instance LogFormatting Void where + forMachine _dtal _x = mempty + +instance LogFormatting () where + forMachine _dtal _x = mempty + +instance LogFormatting SlotNo where + forMachine _dtal slot = + mconcat + [ "kind" .= String "SlotNo" + , "slot" .= toJSON (unSlotNo slot) + ] + +instance + forall blk. + ConvertRawHash blk => + LogFormatting (Point blk) + where + forHuman = renderPointAsPhrase + + forMachine _dtal GenesisPoint = + mconcat + ["kind" .= String "GenesisPoint"] + forMachine dtal (BlockPoint slot h) = + mconcat + [ "kind" .= String "BlockPoint" + , "slot" .= toJSON (unSlotNo slot) + , "headerHash" .= renderHeaderHashForDetails (Proxy @blk) dtal h + ] + +instance + ConvertRawHash blk => + LogFormatting (RealPoint blk) + where + forHuman = renderRealPointAsPhrase + + forMachine dtal p = + mconcat + [ "kind" .= String "Point" + , "slot" .= unSlotNo (realPointSlot p) + , "hash" .= renderHeaderHashForDetails (Proxy @blk) dtal (realPointHash p) + ] + +instance ConvertRawHash blk => LogFormatting (AF.Anchor blk) where + forMachine dtal = \case + AF.AnchorGenesis -> + mconcat + ["kind" .= String "AnchorGenesis"] + AF.Anchor slot hash bno -> + mconcat + [ "kind" .= String "Anchor" + , "slot" .= toJSON (unSlotNo slot) + , "headerHash" .= renderHeaderHashForDetails (Proxy @blk) dtal hash + , "blockNo" .= toJSON (unBlockNo bno) + ] + +instance (ConvertRawHash blk, HasHeader blk) => LogFormatting (AF.AnchoredFragment blk) where + forMachine dtal frag = + mconcat + [ "kind" .= String "AnchoredFragment" + , "anchor" .= forMachine dtal (AF.anchor frag) + , "headPoint" .= forMachine dtal (AF.headPoint frag) + , "length" .= toJSON (AF.length frag) + ] diff --git a/tracing/Ouroboros/Consensus/Tracing/HasIssuer.hs b/tracing/Ouroboros/Consensus/Tracing/HasIssuer.hs new file mode 100644 index 0000000000..600ad0f600 --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/HasIssuer.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ouroboros.Consensus.Tracing.HasIssuer + ( BlockIssuerVerificationKeyHash (..) + , HasIssuer (..) + ) where + +import qualified Cardano.Chain.Block as Byron +import qualified Cardano.Chain.Common as Byron.Common +import qualified Cardano.Crypto.Hash.Class as Crypto +import qualified Cardano.Crypto.Hashing as Byron.Crypto +import qualified Cardano.Ledger.Hashes as SL +import Cardano.Protocol.Crypto (StandardCrypto) +import Data.ByteString (ByteString) +import Data.SOP +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock, Header (..)) +import Ouroboros.Consensus.HardFork.Combinator + ( HardForkBlock + , Header (..) + , OneEraHeader (..) + ) +import Ouroboros.Consensus.Shelley.Ledger.Block (Header (..), ShelleyBlock) +import Ouroboros.Consensus.Shelley.Protocol.Abstract + +-- | Block issuer verification key hash. +data BlockIssuerVerificationKeyHash + = -- | Serialized block issuer verification key hash. + BlockIssuerVerificationKeyHash !ByteString + | -- | There is no block issuer. + -- + -- For example, this could be relevant for epoch boundary blocks (EBBs), + -- genesis blocks, etc. + NoBlockIssuer + deriving (Eq, Show) + +-- | Get the block issuer verification key hash from a block header. +class HasIssuer blk where + -- | Given a block header, return the serialized block issuer verification + -- key hash. + getIssuerVerificationKeyHash :: Header blk -> BlockIssuerVerificationKeyHash + +instance HasIssuer ByronBlock where + getIssuerVerificationKeyHash byronBlkHdr = + case byronHeaderRaw byronBlkHdr of + Byron.ABOBBlockHdr hdr -> + BlockIssuerVerificationKeyHash + -- The raw bytes of the Blake2b_224 hash of the issuer verification + -- key. This matches @cardano-api@'s + -- @serialiseToRawBytes . verificationKeyHash . ByronVerificationKey@. + . Byron.Crypto.abstractHashToBytes + . Byron.Common.unKeyHash + . Byron.Common.hashKey + $ Byron.headerIssuer hdr + Byron.ABOBBoundaryHdr _ -> NoBlockIssuer + +instance + ( ProtoCrypto protocol ~ StandardCrypto + , ProtocolHeaderSupportsProtocol protocol + ) => + HasIssuer (ShelleyBlock protocol era) + where + getIssuerVerificationKeyHash shelleyBlkHdr = + BlockIssuerVerificationKeyHash + -- The raw bytes of the key hash. This matches @cardano-api@'s + -- @serialiseToRawBytes . verificationKeyHash . StakePoolVerificationKey@; + -- the key role is a phantom type, so hashing the block-issuer key + -- directly yields the same bytes as first converting it to a stake + -- pool key. + . Crypto.hashToBytes + . SL.unKeyHash + . SL.hashKey + $ pHeaderIssuer (shelleyHeaderRaw shelleyBlkHdr) + +instance All HasIssuer xs => HasIssuer (HardForkBlock xs) where + getIssuerVerificationKeyHash = + hcollapse + . hcmap (Proxy @HasIssuer) (K . getIssuerVerificationKeyHash) + . getOneEraHeader + . getHardForkHeader diff --git a/tracing/Ouroboros/Consensus/Tracing/KESInfo.hs b/tracing/Ouroboros/Consensus/Tracing/KESInfo.hs new file mode 100644 index 0000000000..42f51c7f9b --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/KESInfo.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Tracing of the KES key state of a block forging credential. +-- +-- 'HasKESInfo' and 'GetKESInfo' project the per-block-type +-- 'ForgeStateUpdateError'\/'ForgeStateInfo' onto the block-type-agnostic +-- 'HotKey.KESInfo', which is what actually gets traced. They live next to the +-- 'LogFormatting' instances that consume them so that a consumer of this +-- sublibrary gets both from a single import. +module Ouroboros.Consensus.Tracing.KESInfo + ( HasKESInfo (..) + , GetKESInfo (..) + , traceAsKESInfo + ) where + +import Cardano.Logging +import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod)) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (ToJSON (..), Value (..), (.=)) +import Data.SOP +import qualified Data.Text as Text +import Ouroboros.Consensus.Block.Forging +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras + ( OneEraForgeStateInfo (..) + , OneEraForgeStateUpdateError (..) + ) +import Ouroboros.Consensus.Node.Tracers (TraceLabelCreds (..)) +import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey +import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock) +-- Brings the orphan @ForgeStateInfo@/@ForgeStateUpdateError@ type-family +-- instances for @ShelleyBlock@ into scope, so the KES instances below can +-- reduce them to @HotKey.KESInfo@/@HotKey.KESEvolutionError@. +import Ouroboros.Consensus.Shelley.Node () +import Ouroboros.Consensus.TypeFamilyWrappers + +-- + +-- * HasKESInfo + +-- +class HasKESInfo blk where + getKESInfo :: Proxy blk -> ForgeStateUpdateError blk -> Maybe HotKey.KESInfo + getKESInfo _ _ = Nothing + +instance HasKESInfo (ShelleyBlock protocol era) where + getKESInfo _ (HotKey.KESCouldNotEvolve ki _) = Just ki + getKESInfo _ (HotKey.KESKeyAlreadyPoisoned ki _) = Just ki + +instance HasKESInfo ByronBlock + +instance All HasKESInfo xs => HasKESInfo (HardForkBlock xs) where + getKESInfo _ = + hcollapse + . hcmap (Proxy @HasKESInfo) getOne + . getOneEraForgeStateUpdateError + where + getOne :: + forall blk. + HasKESInfo blk => + WrapForgeStateUpdateError blk -> + K (Maybe HotKey.KESInfo) blk + getOne = K . getKESInfo (Proxy @blk) . unwrapForgeStateUpdateError + +-- + +-- * GetKESInfo + +-- +class GetKESInfo blk where + getKESInfoFromStateInfo :: Proxy blk -> ForgeStateInfo blk -> Maybe HotKey.KESInfo + getKESInfoFromStateInfo _ _ = Nothing + +instance GetKESInfo (ShelleyBlock protocol era) where + getKESInfoFromStateInfo _ = Just + +instance GetKESInfo ByronBlock + +instance All GetKESInfo xs => GetKESInfo (HardForkBlock xs) where + getKESInfoFromStateInfo _ forgeStateInfo = + case forgeStateInfo of + CurrentEraLacksBlockForging _ -> Nothing + CurrentEraForgeStateUpdated currentEraForgeStateInfo -> + hcollapse + . hcmap (Proxy @GetKESInfo) getOne + . getOneEraForgeStateInfo + $ currentEraForgeStateInfo + where + getOne :: + forall blk. + GetKESInfo blk => + WrapForgeStateInfo blk -> + K (Maybe HotKey.KESInfo) blk + getOne = K . getKESInfoFromStateInfo (Proxy @blk) . unwrapForgeStateInfo + +-- + +-- * Tracer + +-- + +traceAsKESInfo :: + forall m blk. + (GetKESInfo blk, MonadIO m) => + Proxy blk -> + Trace m (TraceLabelCreds HotKey.KESInfo) -> + Trace m (TraceLabelCreds (ForgeStateInfo blk)) +traceAsKESInfo pr tr = traceAsMaybeKESInfo pr (filterTraceMaybe tr) + +traceAsMaybeKESInfo :: + forall m blk. + (GetKESInfo blk, MonadIO m) => + Proxy blk -> + Trace m (Maybe (TraceLabelCreds HotKey.KESInfo)) -> + Trace m (TraceLabelCreds (ForgeStateInfo blk)) +traceAsMaybeKESInfo pr (Trace tr) = + Trace $ + contramap + ( \case + (lc, Right (TraceLabelCreds c e)) -> + case getKESInfoFromStateInfo pr e of + Just kesi -> (lc, Right (Just (TraceLabelCreds c kesi))) + Nothing -> (lc, Right Nothing) + (lc, Left ctrl) -> (lc, Left ctrl) + ) + tr + +-- -------------------------------------------------------------------------------- +-- -- KESInfo Tracer +-- -------------------------------------------------------------------------------- + +deriving newtype instance ToJSON KESPeriod + +instance LogFormatting HotKey.KESInfo where + forMachine _dtal forgeStateInfo = + let currKesPeriod' = currKesPeriod + startKesPeriod + maxKesEvos = endKesPeriod - startKesPeriod + expiryKesPeriod = startKesPeriod + maxKesEvos + kesPeriodsUntilExpiry = max 0 (expiryKesPeriod - currKesPeriod') + in if kesPeriodsUntilExpiry > 7 + then + mconcat + [ "kind" .= String "KESInfo" + , "startPeriod" .= startKesPeriod + , "endPeriod" .= currKesPeriod' + , "evolution" .= endKesPeriod + ] + else + mconcat + [ "kind" .= String "ExpiryLogMessage" + , "keyExpiresIn" .= kesPeriodsUntilExpiry + , "startPeriod" .= startKesPeriod + , "endPeriod" .= currKesPeriod' + , "evolution" .= endKesPeriod + ] + where + HotKey.KESInfo + { HotKey.kesStartPeriod = KESPeriod startKesPeriod + , HotKey.kesEvolution = currKesPeriod + , HotKey.kesEndPeriod = KESPeriod endKesPeriod + } = forgeStateInfo + + forHuman forgeStateInfo = + let currKesPeriod' = currKesPeriod + startKesPeriod + maxKesEvos = endKesPeriod - startKesPeriod + expiryKesPeriod = startKesPeriod + maxKesEvos + kesPeriodsUntilExpiry = max 0 (expiryKesPeriod - currKesPeriod') + in if kesPeriodsUntilExpiry > 7 + then + "KES info startPeriod " + <> (Text.pack . show) startKesPeriod + <> " currPeriod " + <> (Text.pack . show) currKesPeriod' + <> " endPeriod " + <> (Text.pack . show) endKesPeriod + <> ", " + <> (Text.pack . show) kesPeriodsUntilExpiry + <> " KES periods until expiry." + else + "Operational key will expire in " + <> (Text.pack . show) kesPeriodsUntilExpiry + <> " KES periods." + where + HotKey.KESInfo + { HotKey.kesStartPeriod = KESPeriod startKesPeriod + , HotKey.kesEvolution = currKesPeriod + , HotKey.kesEndPeriod = KESPeriod endKesPeriod + } = forgeStateInfo + + asMetrics forgeStateInfo = + let currKesPeriod' = currKesPeriod + startKesPeriod + maxKesEvos = endKesPeriod - startKesPeriod + expiryKesPeriod = startKesPeriod + maxKesEvos + kesPeriodsUntilExpiry = max 0 (expiryKesPeriod - currKesPeriod') + in [ IntM "operationalCertificateStartKESPeriod" (fromIntegral startKesPeriod) + , IntM "operationalCertificateExpiryKESPeriod" (fromIntegral expiryKesPeriod) + , IntM "currentKESPeriod" (fromIntegral currKesPeriod') + , IntM "remainingKESPeriods" (fromIntegral kesPeriodsUntilExpiry) + ] + where + HotKey.KESInfo + { HotKey.kesStartPeriod = KESPeriod startKesPeriod + , HotKey.kesEvolution = currKesPeriod + , HotKey.kesEndPeriod = KESPeriod endKesPeriod + } = forgeStateInfo + +instance MetaTrace HotKey.KESInfo where + namespaceFor HotKey.KESInfo{} = Namespace [] ["StateInfo"] + + severityFor (Namespace _ _) (Just forgeStateInfo) = + Just $ + let currKesPeriod' = currKesPeriod + startKesPeriod + maxKesEvos = endKesPeriod - startKesPeriod + expiryKesPeriod = startKesPeriod + maxKesEvos + kesPeriodsUntilExpiry = max 0 (expiryKesPeriod - currKesPeriod') + in if kesPeriodsUntilExpiry > 7 + then Info + else + if kesPeriodsUntilExpiry <= 1 + then Alert + else Warning + where + HotKey.KESInfo + { HotKey.kesStartPeriod = KESPeriod startKesPeriod + , HotKey.kesEvolution = currKesPeriod + , HotKey.kesEndPeriod = KESPeriod endKesPeriod + } = forgeStateInfo + severityFor (Namespace _ ["StateInfo"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["StateInfo"]) = + Just + "kesStartPeriod \ + \\nkesEndPeriod is kesStartPeriod + tpraosMaxKESEvo\ + \\nkesEvolution is the current evolution or /relative period/." + documentFor _ = Nothing + + metricsDocFor (Namespace _ ["StateInfo"]) = + [ ("operationalCertificateStartKESPeriod", "") + , ("operationalCertificateExpiryKESPeriod", "") + , ("currentKESPeriod", "") + , ("remainingKESPeriods", "") + ] + metricsDocFor _ = [] + + allNamespaces = [Namespace [] ["StateInfo"]] + +instance LogFormatting HotKey.KESEvolutionError where + forMachine dtal (HotKey.KESCouldNotEvolve kesInfo targetPeriod) = + mconcat + [ "kind" .= String "KESCouldNotEvolve" + , "kesInfo" .= forMachine dtal kesInfo + , "targetPeriod" .= targetPeriod + ] + forMachine dtal (HotKey.KESKeyAlreadyPoisoned kesInfo targetPeriod) = + mconcat + [ "kind" .= String "KESKeyAlreadyPoisoned" + , "kesInfo" .= forMachine dtal kesInfo + , "targetPeriod" .= targetPeriod + ] diff --git a/tracing/Ouroboros/Consensus/Tracing/Render.hs b/tracing/Ouroboros/Consensus/Tracing/Render.hs new file mode 100644 index 0000000000..98d28bba2c --- /dev/null +++ b/tracing/Ouroboros/Consensus/Tracing/Render.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Scalar text rendering helpers for Consensus types, shared by the Consensus +-- tracing instances. +-- +-- Moved here from @Cardano.Node.Tracing.Render@ in @cardano-node@. The +-- @cardano-api@-dependent helpers (script hashes, plutus purposes, missing +-- redeemers, incomplete withdrawals) were left behind in @cardano-node@, as +-- @cardano-api@ sits downstream of Consensus. +module Ouroboros.Consensus.Tracing.Render + ( renderChunkNo + , renderHeaderHash + , renderHeaderHashForDetails + , renderChainHash + , renderTipBlockNo + , renderTipHash + , condenseT + , renderPoint + , renderPointAsPhrase + , renderPointForDetails + , renderRealPoint + , renderRealPointAsPhrase + , renderTxId + , renderTxIdForDetails + , renderWithOrigin + ) where + +import Cardano.Logging (DetailLevel (..)) +import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) +import qualified Data.ByteString.Base16 as B16 +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Ouroboros.Consensus.Block (BlockNo (..), ConvertRawHash (..), RealPoint (..)) +import Ouroboros.Consensus.Block.Abstract (Point (..)) +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, TxId) +import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmDB +import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkNo (..)) +import Ouroboros.Consensus.Tracing.ConvertTxId (ConvertTxId (..)) +import Ouroboros.Consensus.Util.Condense (Condense, condense) +import Ouroboros.Network.Block (ChainHash (..), HeaderHash, StandardHash) + +condenseT :: Condense a => a -> Text +condenseT = Text.pack . condense + +renderChunkNo :: ChunkNo -> Text +renderChunkNo = Text.pack . show . unChunkNo + +renderTipBlockNo :: ImmDB.Tip blk -> Text +renderTipBlockNo = Text.pack . show . unBlockNo . ImmDB.tipBlockNo + +renderTipHash :: StandardHash blk => ImmDB.Tip blk -> Text +renderTipHash tInfo = Text.pack . show $ ImmDB.tipHash tInfo + +renderTxIdForDetails :: + ConvertTxId blk => + DetailLevel -> + TxId (GenTx blk) -> + Text +renderTxIdForDetails dtal = trimHashTextForDetails dtal . renderTxId + +renderTxId :: ConvertTxId blk => TxId (GenTx blk) -> Text +renderTxId = Text.decodeLatin1 . B16.encode . txIdToRawBytes + +renderWithOrigin :: (a -> Text) -> WithOrigin a -> Text +renderWithOrigin _ Origin = "origin" +renderWithOrigin render (At a) = render a + +renderSlotNo :: SlotNo -> Text +renderSlotNo = Text.pack . show . unSlotNo + +renderRealPoint :: + forall blk. + ConvertRawHash blk => + RealPoint blk -> + Text +renderRealPoint (RealPoint slotNo headerHash) = + renderHeaderHash (Proxy @blk) headerHash + <> "@" + <> renderSlotNo slotNo + +-- | Render a short phrase describing a 'RealPoint'. +-- e.g. "62292d753b2ee7e903095bc5f10b03cf4209f456ea08f55308e0aaab4350dda4 at +-- slot 39920" +renderRealPointAsPhrase :: + forall blk. + ConvertRawHash blk => + RealPoint blk -> + Text +renderRealPointAsPhrase (RealPoint slotNo headerHash) = + renderHeaderHash (Proxy @blk) headerHash + <> " at slot " + <> renderSlotNo slotNo + +renderPointForDetails :: + forall blk. + ConvertRawHash blk => + DetailLevel -> + Point blk -> + Text +renderPointForDetails dtal point = + case point of + GenesisPoint -> "genesis (origin)" + BlockPoint slot h -> + renderHeaderHashForDetails (Proxy @blk) dtal h + <> "@" + <> renderSlotNo slot + +renderPoint :: ConvertRawHash blk => Point blk -> Text +renderPoint = renderPointForDetails DDetailed + +-- | Render a short phrase describing a 'Point'. +-- e.g. "62292d753b2ee7e903095bc5f10b03cf4209f456ea08f55308e0aaab4350dda4 at +-- slot 39920" or "genesis (origin)" in the case of a genesis point. +renderPointAsPhrase :: forall blk. ConvertRawHash blk => Point blk -> Text +renderPointAsPhrase point = + case point of + GenesisPoint -> "genesis (origin)" + BlockPoint slot h -> + renderHeaderHash (Proxy @blk) h + <> " at slot " + <> renderSlotNo slot + +renderHeaderHashForDetails :: + ConvertRawHash blk => + proxy blk -> + DetailLevel -> + HeaderHash blk -> + Text +renderHeaderHashForDetails p dtal = + trimHashTextForDetails dtal . renderHeaderHash p + +-- | Hex encode and render a 'HeaderHash' as text. +renderHeaderHash :: ConvertRawHash blk => proxy blk -> HeaderHash blk -> Text +renderHeaderHash p = Text.decodeLatin1 . B16.encode . toRawHash p + +renderChainHash :: (HeaderHash blk -> Text) -> ChainHash blk -> Text +renderChainHash _ GenesisHash = "GenesisHash" +renderChainHash p (BlockHash hash) = p hash + +trimHashTextForDetails :: DetailLevel -> Text -> Text +trimHashTextForDetails dtal = + case dtal of + DMinimal -> Text.take 7 + _ -> id diff --git a/tracing/test/Main.hs b/tracing/test/Main.hs new file mode 100644 index 0000000000..0b249af254 --- /dev/null +++ b/tracing/test/Main.hs @@ -0,0 +1,16 @@ +module Main (main) where + +import qualified Test.Consensus.Tracing.Golden as Golden +import qualified Test.Consensus.Tracing.MetaTrace as MetaTrace +import Test.Tasty + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "tracing" + [ MetaTrace.tests + , Golden.tests + ] diff --git a/tracing/test/Test/Consensus/Tracing/Golden.hs b/tracing/test/Test/Consensus/Tracing/Golden.hs new file mode 100644 index 0000000000..86136bf21b --- /dev/null +++ b/tracing/test/Test/Consensus/Tracing/Golden.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +-- | Golden output for the tracing rendering helpers. +-- +-- These functions are what the era tracing instances put into the log, and +-- they were reimplemented off @cardano-api@ when the instances moved here. +-- Two of them silently changed shape in the process, which nothing caught -- +-- hence these files. They pin the output as bytes so that a change to it has +-- to be an explicit, reviewed change to a golden file. +-- +-- A golden file is only ever as good as the review of the diff that created it: +-- these were checked by hand against @cardano-api-11.5.0.0@, the version +-- @cardano-node@ used before the move. +module Test.Consensus.Tracing.Golden (tests) where + +import qualified Cardano.Crypto.Hash.Class as Crypto +import Cardano.Ledger.Address (AccountAddress (..), AccountId (..)) +import Cardano.Ledger.Alonzo.Scripts (AsItem (..), AsIx (..)) +import Cardano.Ledger.BaseTypes + ( Anchor (..) + , Mismatch (..) + , Network (..) + , Relation (..) + , StrictMaybe (..) + , TxIx (..) + , Url + , textToUrl + ) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway (ConwayEra) +import Cardano.Ledger.Conway.Governance + ( GovAction (..) + , ProposalProcedure (..) + , Voter (..) + ) +import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..)) +import Cardano.Ledger.Conway.TxCert (ConwayDelegCert (..), ConwayTxCert (..)) +import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.Dijkstra.Scripts (DijkstraPlutusPurpose (..)) +import Cardano.Ledger.Hashes + ( KeyHash (..) + , KeyRole (..) + , ScriptHash (..) + , unsafeMakeSafeHash + ) +import Cardano.Ledger.Mary.Value (PolicyID (..)) +import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.NonEmpty (NonEmptyMap) +import qualified Data.Map.NonEmpty as NonEmptyMap +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Ouroboros.Consensus.Tracing.Era.Shelley.Render +import System.FilePath (()) +import Test.Tasty +import Test.Tasty.Golden (goldenVsString) +import Test.Util.Paths (getRelPath) + +tests :: TestTree +tests = + testGroup + "Golden" + [ goldenVsString + "Era.Shelley.Render" + ($(getRelPath "golden/tracing") "era-shelley-render.golden") + (pure (report shelleyRender)) + ] + +-- + +-- * The rendered values + +-- + +shelleyRender :: [(String, Text)] +shelleyRender = + concat + [ + [ ("renderScriptHash", renderScriptHash (scriptHash '1')) + , + ( "renderScriptIntegrityHash Nothing" + , json (renderScriptIntegrityHash Nothing) + ) + , + ( "renderScriptIntegrityHash (Just _)" + , json (renderScriptIntegrityHash (Just (unsafeMakeSafeHash (hash '2')))) + ) + , + ( "renderRewardAccount mainnet/key" + , renderRewardAccount (accountAddress Mainnet (KeyHashObj (keyHash '3'))) + ) + , + ( "renderRewardAccount testnet/key" + , renderRewardAccount (accountAddress Testnet (KeyHashObj (keyHash '3'))) + ) + , + ( "renderRewardAccount mainnet/script" + , renderRewardAccount (accountAddress Mainnet (ScriptHashObj (scriptHash '4'))) + ) + , ("renderTxIn", renderTxIn txIn) + ] + , -- Every purpose, by index. This is the ExtraRedeemers field, and it has to + -- keep matching cardano-api's toScriptIndex + ToJSON ScriptWitnessIndex: + -- a "kind" naming the witness index constructor, and "value". + [ ("renderScriptIndex " <> label, json (renderScriptIndex purpose)) + | (label, purpose) <- purposesByIndex + ] + , -- Note the asymmetry: spending, rewarding and guarding render their item + -- directly, the other four wrap it in {"item": ...} via + -- ToJSON (AsItem ix it). That is what cardano-api did. + [ ("renderScriptPurpose " <> label, json (renderScriptPurpose purpose)) + | (label, purpose) <- purposesByItem + ] + , -- Guarding only exists from Dijkstra on, so it needs its own era. Going + -- through DijkstraPlutusPurpose also exercises the other AnyEraScript + -- instance, rather than only Conway's. + + [ ("renderScriptIndex guarding", json (renderScriptIndex guardingByIndex)) + , ("renderScriptPurpose guarding", json (renderScriptPurpose guardingByItem)) + ] + , + [ ("renderMissingRedeemers", json (renderMissingRedeemers missingRedeemers)) + , ("renderIncompleteWithdrawals", json (renderIncompleteWithdrawals withdrawals)) + ] + ] + +purposesByIndex :: [(String, ConwayPlutusPurpose AsIx ConwayEra)] +purposesByIndex = + [ ("spending", ConwaySpending (AsIx 0)) + , ("minting", ConwayMinting (AsIx 1)) + , ("certifying", ConwayCertifying (AsIx 2)) + , ("withdrawing", ConwayWithdrawing (AsIx 3)) + , ("voting", ConwayVoting (AsIx 4)) + , ("proposing", ConwayProposing (AsIx 5)) + ] + +purposesByItem :: [(String, ConwayPlutusPurpose AsItem ConwayEra)] +purposesByItem = + [ ("spending", ConwaySpending (AsItem txIn)) + , ("minting", ConwayMinting (AsItem (PolicyID (scriptHash '5')))) + , ("certifying", ConwayCertifying (AsItem txCert)) + , ("withdrawing", ConwayWithdrawing (AsItem (accountAddress Mainnet (KeyHashObj (keyHash '6'))))) + , ("voting", ConwayVoting (AsItem (StakePoolVoter (keyHash 'b')))) + , ("proposing", ConwayProposing (AsItem proposal)) + ] + +guardingByIndex :: DijkstraPlutusPurpose AsIx DijkstraEra +guardingByIndex = DijkstraGuarding (AsIx 6) + +guardingByItem :: DijkstraPlutusPurpose AsItem DijkstraEra +guardingByItem = DijkstraGuarding (AsItem (scriptHash 'f')) + +txCert :: ConwayTxCert ConwayEra +txCert = ConwayTxCertDeleg (ConwayRegCert (KeyHashObj (keyHash 'c')) SNothing) + +proposal :: ProposalProcedure ConwayEra +proposal = + ProposalProcedure + { pProcDeposit = Coin 1000 + , pProcReturnAddr = accountAddress Mainnet (KeyHashObj (keyHash 'd')) + , pProcGovAction = InfoAction + , pProcAnchor = + Anchor + { anchorUrl = url "https://example.com" + , anchorDataHash = unsafeMakeSafeHash (hash 'e') + } + } + +missingRedeemers :: NonEmpty.NonEmpty (ConwayPlutusPurpose AsItem ConwayEra, ScriptHash) +missingRedeemers = + (ConwaySpending (AsItem txIn), scriptHash '7') + NonEmpty.:| [(ConwayMinting (AsItem (PolicyID (scriptHash '8'))), scriptHash '9')] + +withdrawals :: NonEmptyMap AccountAddress (Mismatch RelEQ Int) +withdrawals = + NonEmptyMap.singleton + (accountAddress Mainnet (KeyHashObj (keyHash '0'))) + Mismatch{mismatchSupplied = 1, mismatchExpected = 2} + +-- + +-- * Fixtures + +-- +-- Deliberately built from a single byte so that the golden file stays readable +-- and a diff points at the rendering rather than at the input. +-- + +hash :: Crypto.HashAlgorithm h => Char -> Crypto.Hash h a +hash c = Crypto.castHash (Crypto.hashWith id (BS8.singleton c)) + +scriptHash :: Char -> ScriptHash +scriptHash = ScriptHash . hash + +keyHash :: Char -> KeyHash r +keyHash = KeyHash . hash + +accountAddress :: Network -> Credential Staking -> AccountAddress +accountAddress n c = AccountAddress n (AccountId c) + +txIn :: TxIn +txIn = TxIn (TxId (unsafeMakeSafeHash (hash 'a'))) (TxIx 0) + +-- | 'textToUrl' only rejects text longer than the given bound, which the +-- literals here are not. +url :: Text -> Url +url t = fromMaybe (error ("golden: not a URL: " <> Text.unpack t)) (textToUrl 64 t) + +-- + +-- * Report rendering + +-- + +json :: Aeson.Value -> Text +json = Text.decodeUtf8 . BL.toStrict . Aeson.encode + +report :: [(String, Text)] -> BL.ByteString +report items = + BL.fromStrict . Text.encodeUtf8 . Text.unlines $ + [Text.pack (pad label) <> " = " <> value | (label, value) <- items] + where + width = maximum (0 : map (length . fst) items) + pad l = l <> replicate (width - length l) ' ' diff --git a/tracing/test/Test/Consensus/Tracing/MetaTrace.hs b/tracing/test/Test/Consensus/Tracing/MetaTrace.hs new file mode 100644 index 0000000000..115ccbf7df --- /dev/null +++ b/tracing/test/Test/Consensus/Tracing/MetaTrace.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Consistency checks over the 'MetaTrace' instances. +-- +-- These need no trace values: everything here is derived from 'allNamespaces' +-- and the namespace-indexed methods. That makes them cheap enough to run over +-- every traced type. What they check is that every namespace in +-- 'allNamespaces' is well formed: it is non-empty and unique, and it has a +-- severity (a missing one silently makes the message unconfigurable), a +-- privacy, a detail level and documentation, each of which has to be +-- answerable from the namespace alone, since the methods are queried with no +-- trace value. And that trace-dispatcher accepts the resulting tree, so that +-- every namespace is addressable. +-- +-- What they do not check is the other direction: 'namespaceFor' is never +-- called, so a constructor whose namespace is missing from 'allNamespaces', +-- or a typo that appears in both places, still passes. Catching that needs +-- trace values, and these types have neither 'Arbitrary' nor 'Enum' +-- instances. +module Test.Consensus.Tracing.MetaTrace (tests) where + +import Cardano.Logging +import Cardano.Protocol.Crypto (StandardCrypto) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Time.Clock (UTCTime) +import Ouroboros.Consensus.Block (Header) +import Ouroboros.Consensus.Block.SupportsSanityCheck (SanityCheckIssue) +import Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockchainTimeEvent) +import Ouroboros.Consensus.Cardano.Block (CardanoBlock) +import Ouroboros.Consensus.Genesis.Governor (TraceGDDEvent) +import Ouroboros.Consensus.Mempool (TraceEventMempool) +import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server (TraceBlockFetchServerEvent) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (TraceChainSyncClientEvent) +import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Jumping +import Ouroboros.Consensus.MiniProtocol.ChainSync.Server (TraceChainSyncServerEvent) +import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server + ( TraceLocalTxSubmissionServerEvent + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + ( TracePerasCertDiffusionInbound + , TracePerasCertDiffusionOutbound + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasVote + ( TracePerasVoteDiffusionInbound + , TracePerasVoteDiffusionOutbound + ) +import Ouroboros.Consensus.Node.GSM (TraceGsmEvent) +import Ouroboros.Consensus.Node.Tracers + ( TraceForgeEvent + , TracePerasCertInclusionEvent + , TracePerasVoteForgingEvent + ) +import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey +import Ouroboros.Consensus.Protocol.Praos.AgentClient (KESAgentClientTrace) +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import Ouroboros.Consensus.Tracing + ( ClientMetrics + , ConsensusStartupException + , ReplayBlockStats + ) +import Ouroboros.Network.Block (Tip) +import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch +import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) +import Test.Tasty +import Test.Tasty.HUnit + +type Blk = CardanoBlock StandardCrypto + +-- | Stand-in for the peer type of the per-peer tracers. +-- +-- No 'MetaTrace' method looks at it -- namespaces, severities and documentation +-- are the same whatever a peer is -- so this picks the simplest inhabitant +-- rather than dragging in the node's address types. +type Peer = () + +tests :: TestTree +tests = + testGroup + "MetaTrace" + [ testGroup + "consensus" + [ metaTrace @(TraceForgeEvent Blk) "TraceForgeEvent" + , metaTrace @(TraceEventMempool Blk) "TraceEventMempool" + , metaTrace @(TraceChainSyncClientEvent Blk) "TraceChainSyncClientEvent" + , metaTrace @(TraceChainSyncServerEvent Blk) "TraceChainSyncServerEvent" + , metaTrace @(TraceBlockFetchServerEvent Blk) "TraceBlockFetchServerEvent" + , metaTrace @(TraceLocalTxSubmissionServerEvent Blk) + "TraceLocalTxSubmissionServerEvent" + , metaTrace @(TraceGsmEvent (Tip Blk)) "TraceGsmEvent" + , metaTrace @(TraceBlockchainTimeEvent UTCTime) "TraceBlockchainTimeEvent" + , metaTrace @SanityCheckIssue "SanityCheckIssue" + , metaTrace @HotKey.KESInfo "KESInfo" + , metaTrace @ConsensusStartupException "ConsensusStartupException" + , metaTrace @ReplayBlockStats "ReplayBlockStats" + , metaTrace @ClientMetrics "ClientMetrics" + , metaTrace @(TraceGDDEvent Peer Blk) "TraceGDDEvent" + , metaTrace @(Jumping.TraceEventCsj Peer Blk) "Jumping.TraceEventCsj" + , metaTrace @(Jumping.TraceEventDbf Peer) "Jumping.TraceEventDbf" + , metaTrace @(BlockFetch.TraceFetchClientState (Header Blk)) + "BlockFetch.TraceFetchClientState" + , metaTrace @(TraceDecisionEvent Peer (Header Blk)) "TraceDecisionEvent" + , metaTrace @KESAgentClientTrace "KESAgentClientTrace" + ] + , -- Only ChainDB. The LedgerDB, ImmutableDB, VolatileDB, PerasCertDB and + -- PerasVoteDB tracers are not separate: ChainDbArgs derives each of them + -- from the ChainDB tracer, and ChainDB.TraceEvent's allNamespaces maps all + -- of their namespaces in under LedgerEvent, ImmDbEvent and so on. Listing + -- them here as well checked every one of those namespaces twice, under two + -- different names. + testGroup + "storage" + [ metaTrace @(ChainDB.TraceEvent Blk) "ChainDB.TraceEvent" + ] + , testGroup + "peras" + [ metaTrace @(TracePerasCertInclusionEvent Blk) "TracePerasCertInclusionEvent" + , metaTrace @(TracePerasVoteForgingEvent Blk) "TracePerasVoteForgingEvent" + , metaTrace @(TracePerasCertDiffusionInbound Blk) "TracePerasCertDiffusionInbound" + , metaTrace @(TracePerasCertDiffusionOutbound Blk) "TracePerasCertDiffusionOutbound" + , metaTrace @(TracePerasVoteDiffusionInbound Blk) "TracePerasVoteDiffusionInbound" + , metaTrace @(TracePerasVoteDiffusionOutbound Blk) "TracePerasVoteDiffusionOutbound" + ] + ] + +-- | The checks that must hold for any 'MetaTrace' instance. +metaTrace :: forall a. MetaTrace a => String -> TestTree +metaTrace name = + testGroup + name + [ testCase "allNamespaces is non-empty" $ + assertBool "no namespaces at all" (not (null nss)) + , testCase "no namespace is empty" $ + assertNoOffenders + "namespace with no components" + [ns | ns <- nss, null (nsGetComplete ns)] + , testCase "namespaces are unique" $ + assertNoOffenders "namespace listed more than once" duplicates + , testCase "every namespace has a severity" $ + assertNoOffenders "no severityFor" [ns | ns <- nss, Nothing <- [severityFor ns Nothing]] + , testCase "every namespace has a privacy" $ + assertNoOffenders "no privacyFor" [ns | ns <- nss, Nothing <- [privacyFor ns Nothing]] + , testCase "every namespace has a detail level" $ + assertNoOffenders "no detailsFor" [ns | ns <- nss, Nothing <- [detailsFor ns Nothing]] + , -- A ratchet rather than a clean sheet: the namespaces in + -- 'knownUndocumented' arrived undocumented and are recorded so that new + -- ones cannot creep in. Write the documentation and delete the entry; the + -- test below makes sure the list does not go stale. + testCase "every namespace is documented" $ + assertNoOffenders + "no documentFor, or blank" + [ns | ns <- nss, not (documented ns), not (known ns)] + , testCase "the undocumented-namespace list has no stale entries" $ + assertNoOffenders + "documented now, so drop it from knownUndocumented" + [ns | ns <- nss, documented ns, known ns] + , -- The same check cardano-node runs over the assembled node configuration, + -- here over one type's namespaces in isolation: it rejects a namespace that + -- stops in the middle of another, which would make it unaddressable. + testCase "trace-dispatcher accepts the namespace tree" $ + case checkTraceConfiguration' emptyTraceConfig (map nsGetTuple nss) of + [] -> pure () + warnings -> assertFailure (Text.unpack (Text.intercalate "\n" warnings)) + ] + where + nss :: [Namespace a] + nss = allNamespaces + + documented ns = case documentFor ns of + Nothing -> False + Just doc -> not (Text.null (Text.strip doc)) + + known ns = (name, nsToText ns) `Set.member` knownUndocumented + + duplicates = + [ ns + | ns <- nss + , let complete = nsGetComplete ns + , length (filter (== complete) (map nsGetComplete nss)) > 1 + ] + + assertNoOffenders :: String -> [Namespace a] -> Assertion + assertNoOffenders what offenders = + assertBool + (what <> ": " <> show (Set.toList (Set.fromList (map render offenders)))) + (null offenders) + + render :: Namespace a -> String + render = Text.unpack . nsToText + +-- | Namespaces that have no documentation yet, keyed by the traced type. +-- +-- All of these predate the move of the tracing instances into Consensus, and +-- live in ChainDB, ImmutableDB, LedgerDB and the forge tracer. They are listed +-- so that the check above can still reject a newly added namespace with no +-- documentation. Shrink this list, never grow it. +knownUndocumented :: Set.Set (String, Text.Text) +knownUndocumented = + Set.fromList + [ ("BlockFetch.TraceFetchClientState", "CompletedBlockFetch") + , ("ChainDB.TraceEvent", "AddBlockEvent.AddBlockValidation.UpdateLedgerDb") + , ("ChainDB.TraceEvent", "AddBlockEvent.AddedReprocessLoEBlocksToQueue") + , ("ChainDB.TraceEvent", "AddBlockEvent.ChainSelectionLoEDebug") + , ("ChainDB.TraceEvent", "AddBlockEvent.PoppedBlockFromQueue") + , ("ChainDB.TraceEvent", "AddBlockEvent.PoppedReprocessLoEBlocksFromQueue") + , ("ChainDB.TraceEvent", "AddBlockEvent.PoppingFromQueue") + , ("ChainDB.TraceEvent", "ImmDbEvent.CacheEvent.PastChunkExpired") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.InvalidChunkFile") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.InvalidPrimaryIndex") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.InvalidSecondaryIndex") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.MissingChunkFile") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.MissingPrimaryIndex") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.MissingSecondaryIndex") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.RewritePrimaryIndex") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.RewriteSecondaryIndex") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.StartedValidatingChunk") + , ("ChainDB.TraceEvent", "ImmDbEvent.ChunkValidation.ValidatedChunk") + , ("ChainDB.TraceEvent", "ImmDbEvent.DBAlreadyClosed") + , ("ChainDB.TraceEvent", "InitChainSelEvent.Validation.UpdateLedgerDb") + , ("ChainDB.TraceEvent", "IteratorEvent.UnknownRangeRequested.ForkTooOld") + , ("ChainDB.TraceEvent", "IteratorEvent.UnknownRangeRequested.MissingBlock") + , ("KESAgentClientTrace", "KESAgentClientException") + , ("KESAgentClientTrace", "ServiceClientAbnormalTermination") + , ("KESAgentClientTrace", "ServiceClientAttemptReconnect") + , ("KESAgentClientTrace", "ServiceClientConnected") + , ("KESAgentClientTrace", "ServiceClientDeclinedKey") + , ("KESAgentClientTrace", "ServiceClientDriverTrace") + , ("KESAgentClientTrace", "ServiceClientDroppedKey") + , ("KESAgentClientTrace", "ServiceClientOpCertNumberCheck") + , ("KESAgentClientTrace", "ServiceClientReceivedKey") + , ("KESAgentClientTrace", "ServiceClientSocketClosed") + , ("KESAgentClientTrace", "ServiceClientStopped") + , ("KESAgentClientTrace", "ServiceClientVersionHandshakeFailed") + , ("KESAgentClientTrace", "ServiceClientVersionHandshakeTrace") + , ("TraceForgeEvent", "ForgeTickedLedgerState") + , ("TraceForgeEvent", "ForgingMempoolSnapshot") + ]