diff --git a/bench/locli/locli.cabal b/bench/locli/locli.cabal index ba55c43f405..f5f68005071 100644 --- a/bench/locli/locli.cabal +++ b/bench/locli/locli.cabal @@ -113,7 +113,7 @@ library , hashable , optparse-applicative-fork >= 0.18.1 , ouroboros-consensus - , ouroboros-network-api ^>= 0.10 + , ouroboros-network-api ^>= 0.11 , sop-core , split , statistics @@ -158,7 +158,7 @@ test-suite test-locli build-depends: cardano-prelude , containers , hedgehog - , hedgehog-extras ^>= 0.6.4 + , hedgehog-extras >= 0.6.4 && <0.6.5.1 , locli , text diff --git a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal index b548ac79948..fef8dea1d2a 100644 --- a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal +++ b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal @@ -82,10 +82,10 @@ library -- IOG dependencies -------------------------- build-depends: - , cardano-api ^>=10.1 - , plutus-ledger-api ^>=1.36 - , plutus-tx ^>=1.36 - , plutus-tx-plugin ^>=1.36 + , cardano-api ^>=10.4 + , plutus-ledger-api ^>=1.37 + , plutus-tx ^>=1.37 + , plutus-tx-plugin ^>=1.37 ------------------------ -- Non-IOG dependencies diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs index d17ca92c4e6..1b65bec2129 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs @@ -13,7 +13,7 @@ module Cardano.Benchmarking.GeneratorTx.NodeToNode , benchmarkConnectTxSubmit ) where -import Cardano.Prelude (forever, liftIO) +import Cardano.Prelude (forever, liftIO, throwIO) import Prelude import "contra-tracer" Control.Tracer (Tracer (..)) @@ -25,7 +25,8 @@ import Data.ByteString.Lazy (ByteString) import Data.Foldable (fold) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) -import Data.Void (Void) +import Data.Void (Void, absurd) +import qualified Network.Mux as Mux import Network.Socket (AddrInfo (..)) import System.Random (newStdGen) @@ -45,7 +46,7 @@ import Ouroboros.Network.DeltaQ (defaultGSV) import Ouroboros.Network.Driver (runPeer, runPeerWithLimits) import Ouroboros.Network.KeepAlive import Ouroboros.Network.Magic -import Ouroboros.Network.Mux (MiniProtocolCb (..), MuxMode (..), +import Ouroboros.Network.Mux (MiniProtocolCb (..), OuroborosApplication (..), OuroborosBundle, RunMiniProtocol (..)) import Ouroboros.Network.NodeToClient (chainSyncPeerNull) import Ouroboros.Network.NodeToNode (NetworkConnectTracers (..)) @@ -84,8 +85,8 @@ benchmarkConnectTxSubmit -- ^ the particular txSubmission peer -> IO () -benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codecConfig networkMagic remoteAddr myTxSubClient = - NtN.connectTo +benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codecConfig networkMagic remoteAddr myTxSubClient = do + done <- NtN.connectTo (socketSnocket envIOManager) NetworkConnectTracers { nctMuxTracer = mempty, @@ -94,6 +95,11 @@ benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codec peerMultiplex (addrAddress <$> Nothing) (addrAddress remoteAddr) + case done of + Left err -> throwIO err + Right choice -> case choice of + Left () -> return () + Right void -> absurd void where ownPeerSharing = PeerSharingDisabled mkApp :: OuroborosBundle mode initiatorCtx responderCtx bs m a b @@ -114,7 +120,7 @@ benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codec peerMultiplex :: NtN.Versions NodeToNodeVersion NtN.NodeToNodeVersionData (OuroborosApplication - 'InitiatorMode + 'Mux.InitiatorMode (MinimalInitiatorContext NtN.RemoteAddress) (ResponderContext NtN.RemoteAddress) ByteString IO () Void) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs index e2d98eddf78..af229b362f0 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs @@ -45,7 +45,7 @@ import Cardano.Tracing.OrphanInstances.Consensus () import Cardano.Tracing.OrphanInstances.Network () import Cardano.Tracing.OrphanInstances.Shelley () -import Ouroboros.Network.Protocol.TxSubmission2.Type (TokBlockingStyle (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type (SingBlockingStyle (..)) import Cardano.Api hiding (Active) import Cardano.TxGenerator.Types (TPSRate, TxGenError) @@ -124,11 +124,11 @@ mkSubmissionSummary startTime reportsRefs txStreamSource :: forall era. MVar (StreamState (TxStream IO era)) -> TpsThrottle -> TxSource era txStreamSource streamRef tpsThrottle = Active worker where - worker :: forall m blocking . MonadIO m => TokBlockingStyle blocking -> Req -> m (TxSource era, [Tx era]) + worker :: forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [Tx era]) worker blocking req = do (done, txCount) <- case blocking of - TokBlocking -> liftIO $ consumeTxsBlocking tpsThrottle req - TokNonBlocking -> liftIO $ consumeTxsNonBlocking tpsThrottle req + SingBlocking -> liftIO $ consumeTxsBlocking tpsThrottle req + SingNonBlocking -> liftIO $ consumeTxsNonBlocking tpsThrottle req txList <- liftIO $ unFold txCount case done of Stop -> return (Exhausted, txList) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs index 577c47df682..ef33626b5a0 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs @@ -46,7 +46,7 @@ import qualified Ouroboros.Consensus.Shelley.Ledger.Mempool as Mempool (TxId (Sh import Ouroboros.Network.Protocol.TxSubmission2.Client (ClientStIdle (..), ClientStTxIds (..), ClientStTxs (..), TxSubmissionClient (..)) import Ouroboros.Network.Protocol.TxSubmission2.Type (BlockingReplyList (..), - NumTxIdsToAck (..), NumTxIdsToReq (..), TokBlockingStyle (..)) + NumTxIdsToAck (..), NumTxIdsToReq (..), SingBlockingStyle (..)) import Ouroboros.Network.SizeInBytes import Prelude (error, fail) @@ -71,14 +71,14 @@ data TxSource era = Exhausted | Active (ProduceNextTxs era) -type ProduceNextTxs era = (forall m blocking . MonadIO m => TokBlockingStyle blocking -> Req -> m (TxSource era, [Tx era])) +type ProduceNextTxs era = (forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [Tx era])) -produceNextTxs :: forall m blocking era . MonadIO m => TokBlockingStyle blocking -> Req -> LocalState era -> m (LocalState era, [Tx era]) +produceNextTxs :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> LocalState era -> m (LocalState era, [Tx era]) produceNextTxs blocking req (txProducer, unack, stats) = do (newTxProducer, txList) <- produceNextTxs' blocking req txProducer return ((newTxProducer, unack, stats), txList) -produceNextTxs' :: forall m blocking era . MonadIO m => TokBlockingStyle blocking -> Req -> TxSource era -> m (TxSource era, [Tx era]) +produceNextTxs' :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> TxSource era -> m (TxSource era, [Tx era]) produceNextTxs' _ _ Exhausted = return (Exhausted, []) produceNextTxs' blocking req (Active callback) = callback blocking req @@ -99,10 +99,10 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = TxSubmissionClient $ pure $ client (initialTxSource, UnAcked [], SubmissionThreadStats 0 0 0) where - discardAcknowledged :: TokBlockingStyle a -> Ack -> LocalState era -> m (LocalState era) + discardAcknowledged :: SingBlockingStyle a -> Ack -> LocalState era -> m (LocalState era) discardAcknowledged blocking (Ack ack) (txSource, UnAcked unAcked, stats) = do when (tokIsBlocking blocking && ack /= length unAcked) $ do - let err = "decideAnnouncement: TokBlocking, but length unAcked != ack" + let err = "decideAnnouncement: SingBlocking, but length unAcked != ack" traceWith bmtr (TraceBenchTxSubError err) fail (T.unpack err) let (stillUnacked, acked) = L.splitAtEnd ack unAcked @@ -123,7 +123,7 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = requestTxIds :: forall blocking. LocalState era - -> TokBlockingStyle blocking + -> SingBlockingStyle blocking -> NumTxIdsToAck -> NumTxIdsToReq -> m (ClientStTxIds blocking (GenTxId CardanoBlock) (GenTx CardanoBlock) m ()) @@ -140,7 +140,7 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = traceWith bmtr $ SubmissionClientUnAcked (getTxId . getTxBody <$> outs) case blocking of - TokBlocking -> case NE.nonEmpty newTxs of + SingBlocking -> case NE.nonEmpty newTxs of Nothing -> do traceWith tr EndOfProtocol endOfProtocolCallback stats @@ -148,7 +148,7 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = (Just txs) -> pure $ SendMsgReplyTxIds (BlockingReply $ txToIdSize <$> txs) (client stateC) - TokNonBlocking -> pure $ SendMsgReplyTxIds + SingNonBlocking -> pure $ SendMsgReplyTxIds (NonBlockingReply $ txToIdSize <$> newTxs) (client stateC) @@ -196,17 +196,17 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = fromGenTxId (Block.GenTxIdConway (Mempool.ShelleyTxId i)) = fromShelleyTxId i fromGenTxId _ = error "TODO: fix incomplete match" - tokIsBlocking :: TokBlockingStyle a -> Bool + tokIsBlocking :: SingBlockingStyle a -> Bool tokIsBlocking = \case - TokBlocking -> True - TokNonBlocking -> False + SingBlocking -> True + SingNonBlocking -> False - reqIdsTrace :: Ack -> Req -> TokBlockingStyle a -> NodeToNodeSubmissionTrace + reqIdsTrace :: Ack -> Req -> SingBlockingStyle a -> NodeToNodeSubmissionTrace reqIdsTrace ack req = \case - TokBlocking -> ReqIdsBlocking ack req - TokNonBlocking -> ReqIdsNonBlocking ack req + SingBlocking -> ReqIdsBlocking ack req + SingNonBlocking -> ReqIdsNonBlocking ack req - idListTrace :: ToAnnce tx -> TokBlockingStyle a -> NodeToNodeSubmissionTrace + idListTrace :: ToAnnce tx -> SingBlockingStyle a -> NodeToNodeSubmissionTrace idListTrace (ToAnnce toAnn) = \case - TokBlocking -> IdsListBlocking $ length toAnn - TokNonBlocking -> IdsListNonBlocking $ length toAnn + SingBlocking -> IdsListBlocking $ length toAnn + SingNonBlocking -> IdsListNonBlocking $ length toAnn diff --git a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs index e20db4daa5a..4ca580ed717 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs @@ -51,7 +51,7 @@ import qualified Control.Concurrent.STM as STM (TVar) import Data.Text import Data.Time.Clock (DiffTime, NominalDiffTime) import GHC.Generics -import Network.Mux (WithMuxBearer (..)) +import qualified Network.Mux as Mux data AsyncBenchmarkControl = AsyncBenchmarkControl @@ -149,7 +149,7 @@ data NodeToNodeSubmissionTrace type SendRecvTxSubmission2 = TraceSendRecv (TxSubmission2 (GenTxId CardanoBlock) (GenTx CardanoBlock)) -type SendRecvConnect = WithMuxBearer +type SendRecvConnect = Mux.WithBearer RemoteConnectionId (TraceSendRecv (Handshake NodeToNodeVersion diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs index e2f8f25acbd..9a2d1bad7c2 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs @@ -259,7 +259,7 @@ preExecutePlutusV3 (major, _minor) (PlutusScript _ (PlutusScriptSerialised (scri { PlutusV3.txInfoInputs = [] , PlutusV3.txInfoOutputs = [] , PlutusV3.txInfoFee = 0 - , PlutusV3.txInfoMint = mempty + , PlutusV3.txInfoMint = PlutusV3.emptyMintValue , PlutusV3.txInfoTxCerts = [] , PlutusV3.txInfoWdrl = PlutusV3.unsafeFromList [] , PlutusV3.txInfoValidRange = PlutusV3.always diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index b8275a8da51..886053e74d2 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -106,7 +106,7 @@ library , attoparsec-aeson , base16-bytestring , bytestring - , cardano-api ^>= 10.1 + , cardano-api ^>= 10.4 , cardano-binary , cardano-cli ^>= 10.1 , cardano-crypto-class @@ -158,6 +158,7 @@ library , transformers-except , unordered-containers , yaml + , microlens default-language: Haskell2010 default-extensions: OverloadedStrings diff --git a/cabal.project b/cabal.project index bef93a67ebc..6a18bbf7326 100644 --- a/cabal.project +++ b/cabal.project @@ -13,8 +13,8 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2024-10-10T00:52:24Z - , cardano-haskell-packages 2024-10-30T10:23:17Z + , hackage.haskell.org 2024-12-10T16:20:07Z + , cardano-haskell-packages 2024-12-18T14:29:04Z packages: cardano-node @@ -60,11 +60,65 @@ package plutus-scripts-bench constraints: , wai-extra < 3.1.15 , Cabal < 3.14 + , hedgehog-extras <0.6.5.1 allow-newer: , katip:Win32 , ekg-wai:time + , *:hedgehog-extras -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: 4920b7a8e1a639e6b6a85611bef6d541e21d012a + --sha256: sha256-mrGXtC/mStln5KqoXlruKYl2vHYZhgw3biRlZm82h7A= + subdir: + cardano-client + cardano-ping + monoidal-synchronisation + network-mux + ntp-client + ouroboros-network + ouroboros-network-api + ouroboros-network-framework + ouroboros-network-mock + ouroboros-network-protocols + ouroboros-network-testing + quickcheck-monoids + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus.git + tag: f2d134da6d6d4f7bcbfb85ba94b30f49b3f2b7c6 + --sha256: sha256-4Lu716WX9S+5dguxa8lUjAgeCQYsxj9QZZ9xLyyjivQ= + subdir: + ouroboros-consensus + ouroboros-consensus-cardano + ouroboros-consensus-protocol + ouroboros-consensus-diffusion + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api.git + tag: 04ac6b36284ea823da0a7b88210c03b586f7f808 + --sha256: sha256-LcZe9GcH2qRvNCk4leJHMLEX0KMiqbkYP4xACBE/znE= + subdir: + cardano-api + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-cli.git + tag: e2940caf43f5ba3194173523369553c93c2340b7 + --sha256: sha256-Bzic7wIBU8Md/vzj87d9kgdpOGfTXOtjBYLyTR/rZ5g= + subdir: + cardano-cli + +source-repository-package + type: git + location: https://github.com/neilmayhew/ekg-forward.git + tag: 4ba8bb693093f6cf54d43d6e9bbce1e08b0457dd + --sha256: sha256-g0gYqzRGjmZwxEzihJ4JifJe+GRfdLIMzaot7rUcjlI= diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index 0d9a6c835f9..452eafd5d27 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -74,7 +74,7 @@ test-suite chairman-tests , data-default-class , filepath , hedgehog - , hedgehog-extras ^>= 0.6.4 + , hedgehog-extras >= 0.6.4 && <0.6.5.1 , network , process , random diff --git a/cardano-node/ChangeLog.md b/cardano-node/ChangeLog.md index 7e3aff8ac10..76e7cfd2474 100644 --- a/cardano-node/ChangeLog.md +++ b/cardano-node/ChangeLog.md @@ -9,6 +9,11 @@ - `--mempool-capacity-override` and `--no-mempool-capacity-override` can be set in the configuration file via the key `MempoolCapacityBytesOverride`. - `--snapshot-interval` can be set in the configuration file via the key `SnapshotInterval`. - `--num-of-disk-snapshots` can be set in the configuration file via the key `NumOfDiskSnapshots`. +- Ledger peer snapshot path entry added to topology JSON parser, + which a new decoder function `readPeerSnapshotFile` processes + at startup and SIGHUP. Data is available to the diffusion layer + via TVar. + - Use metric names of old-tracing in new-tracing as well, and fix some metrics in new tracing. diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index c2f8e5c5873..d498612ac87 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-node -version: 10.1.2 +version: 10.1.3 synopsis: The cardano full node description: The cardano full node. category: Cardano, @@ -145,7 +145,7 @@ library , async , base16-bytestring , bytestring - , cardano-api ^>= 10.1 + , cardano-api ^>= 10.4 , cardano-crypto-class , cardano-crypto-wrapper , cardano-git-rev ^>=0.2.2 @@ -156,7 +156,7 @@ library , cardano-ledger-binary , cardano-ledger-byron -- TODO: remove constraint at next ledger bump - , cardano-ledger-conway ^>= 1.17.2 + , cardano-ledger-conway ^>= 1.18 , cardano-ledger-core , cardano-ledger-shelley , cardano-prelude @@ -169,17 +169,17 @@ library , deepseq , directory , dns - , ekg + , ekg-wai , ekg-core , filepath , formatting , generic-data , hostname , io-classes >= 1.4 - , iohk-monitoring < 0.2 + , iohk-monitoring ^>= 0.2 , iproute , lobemo-backend-aggregation - , lobemo-backend-ekg < 0.2 + , lobemo-backend-ekg ^>= 0.2 , lobemo-backend-monitoring , lobemo-backend-trace-forwarder , mtl @@ -191,13 +191,14 @@ library , ouroboros-consensus-cardano ^>= 0.20 , ouroboros-consensus-diffusion ^>= 0.18 , ouroboros-consensus-protocol - , ouroboros-network-api ^>= 0.10 - , ouroboros-network ^>= 0.17 + , ouroboros-network-api ^>= 0.11 + , ouroboros-network ^>= 0.18 , ouroboros-network-framework - , ouroboros-network-protocols ^>= 0.11 + , ouroboros-network-protocols ^>= 0.12 , prettyprinter , prettyprinter-ansi-terminal , psqueues + , resource-registry , safe-exceptions , scientific , si-timers @@ -209,11 +210,12 @@ library , time , trace-dispatcher ^>= 2.7.0 , trace-forward ^>= 2.2.8 - , trace-resources ^>= 0.2.2 + , trace-resources ^>= 0.2.3 , tracer-transformers , transformers , transformers-except - , typed-protocols >= 0.1 + , typed-protocols >= 0.3 + , typed-protocols-stateful >= 0.3 , yaml executable cardano-node diff --git a/cardano-node/src/Cardano/Node/Configuration/Logging.hs b/cardano-node/src/Cardano/Node/Configuration/Logging.hs index cad45ea0495..caf41dbb8db 100644 --- a/cardano-node/src/Cardano/Node/Configuration/Logging.hs +++ b/cardano-node/src/Cardano/Node/Configuration/Logging.hs @@ -48,7 +48,7 @@ import Data.Version (showVersion) import System.Metrics.Counter (Counter) import System.Metrics.Gauge (Gauge) import System.Metrics.Label (Label) -import qualified System.Remote.Monitoring as EKG +import qualified System.Remote.Monitoring.Wai as EKG import Cardano.BM.Backend.Aggregation (plugin) import Cardano.BM.Backend.EKGView (plugin) diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 3ce3341e431..be72eda35c1 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -33,12 +35,12 @@ import Cardano.Tracing.Config import Cardano.Tracing.OrphanInstances.Network () import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..)) -import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) +import Ouroboros.Consensus.Node (NodeDatabasePaths (..), + pattern DoDiskSnapshotChecksum) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) -import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (NumOfDiskSnapshots (..), - SnapshotInterval (..)) -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (..)) -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag, + NumOfDiskSnapshots (..), SnapshotInterval (..)) +import Ouroboros.Network.Diffusion.Configuration as Configuration import Control.Monad (when) import Data.Aeson @@ -103,9 +105,10 @@ data NodeConfiguration , ncProtocolConfig :: !NodeProtocolConfiguration -- Node parameters, not protocol-specific: - , ncDiffusionMode :: !DiffusionMode - , ncNumOfDiskSnapshots :: !NumOfDiskSnapshots - , ncSnapshotInterval :: !SnapshotInterval + , ncDiffusionMode :: !DiffusionMode + , ncNumOfDiskSnapshots :: !NumOfDiskSnapshots + , ncSnapshotInterval :: !SnapshotInterval + , ncDoDiskSnapshotChecksum :: !(Flag "DoDiskSnapshotChecksum") -- | During the development and integration of new network protocols -- (node-to-node and node-to-client) we wish to be able to test them @@ -150,13 +153,25 @@ data NodeConfiguration , ncAcceptedConnectionsLimit :: !AcceptedConnectionsLimit -- P2P governor targets - , ncTargetNumberOfRootPeers :: Int - , ncTargetNumberOfKnownPeers :: Int - , ncTargetNumberOfEstablishedPeers :: Int - , ncTargetNumberOfActivePeers :: Int - , ncTargetNumberOfKnownBigLedgerPeers :: Int - , ncTargetNumberOfEstablishedBigLedgerPeers :: Int - , ncTargetNumberOfActiveBigLedgerPeers :: Int + , ncDeadlineTargetOfRootPeers :: !Int + , ncDeadlineTargetOfKnownPeers :: !Int + , ncDeadlineTargetOfEstablishedPeers :: !Int + , ncDeadlineTargetOfActivePeers :: !Int + , ncDeadlineTargetOfKnownBigLedgerPeers :: !Int + , ncDeadlineTargetOfEstablishedBigLedgerPeers :: !Int + , ncDeadlineTargetOfActiveBigLedgerPeers :: !Int + , ncSyncTargetOfActivePeers :: !Int + , ncSyncTargetOfKnownBigLedgerPeers :: !Int + , ncSyncTargetOfEstablishedBigLedgerPeers :: !Int + , ncSyncTargetOfActiveBigLedgerPeers :: !Int + + -- Used to determine which set of peer targets to use + -- by the diffusion layer when syncing + , ncConsensusMode :: !ConsensusMode + + -- Minimum number of active big ledger peers we must be connected to + -- in Genesis mode + , ncMinBigLedgerPeersForTrustedState :: MinBigLedgerPeersForTrustedState -- Enable experimental P2P mode , ncEnableP2P :: SomeNetworkP2PMode @@ -185,9 +200,10 @@ data PartialNodeConfiguration , pncProtocolConfig :: !(Last NodeProtocolConfiguration) -- Node parameters, not protocol-specific: - , pncDiffusionMode :: !(Last DiffusionMode ) + , pncDiffusionMode :: !(Last DiffusionMode) , pncNumOfDiskSnapshots :: !(Last NumOfDiskSnapshots) , pncSnapshotInterval :: !(Last SnapshotInterval) + , pncDoDiskSnapshotChecksum :: !(Last (Flag "DoDiskSnapshotChecksum")) , pncExperimentalProtocolsEnabled :: !(Last Bool) -- BlockFetch configuration @@ -213,13 +229,23 @@ data PartialNodeConfiguration , pncAcceptedConnectionsLimit :: !(Last AcceptedConnectionsLimit) -- P2P governor targets - , pncTargetNumberOfRootPeers :: !(Last Int) - , pncTargetNumberOfKnownPeers :: !(Last Int) - , pncTargetNumberOfEstablishedPeers :: !(Last Int) - , pncTargetNumberOfActivePeers :: !(Last Int) - , pncTargetNumberOfKnownBigLedgerPeers :: !(Last Int) - , pncTargetNumberOfEstablishedBigLedgerPeers :: !(Last Int) - , pncTargetNumberOfActiveBigLedgerPeers :: !(Last Int) + , pncDeadlineTargetOfRootPeers :: !(Last Int) + , pncDeadlineTargetOfKnownPeers :: !(Last Int) + , pncDeadlineTargetOfEstablishedPeers :: !(Last Int) + , pncDeadlineTargetOfActivePeers :: !(Last Int) + , pncDeadlineTargetOfKnownBigLedgerPeers :: !(Last Int) + , pncDeadlineTargetOfEstablishedBigLedgerPeers :: !(Last Int) + , pncDeadlineTargetOfActiveBigLedgerPeers :: !(Last Int) + , pncSyncTargetOfActivePeers :: !(Last Int) + , pncSyncTargetOfKnownBigLedgerPeers :: !(Last Int) + , pncSyncTargetOfEstablishedBigLedgerPeers :: !(Last Int) + , pncSyncTargetOfActiveBigLedgerPeers :: !(Last Int) + -- Minimum number of active big ledger peers we must be connected to + -- in Genesis mode + , pncMinBigLedgerPeersForTrustedState :: !(Last MinBigLedgerPeersForTrustedState) + + -- Consensus mode for diffusion layer + , pncConsensusMode :: !(Last ConsensusMode) -- Enable experimental P2P mode , pncEnableP2P :: !(Last NetworkP2PMode) @@ -250,6 +276,8 @@ instance FromJSON PartialNodeConfiguration where <- Last . fmap RequestedNumOfDiskSnapshots <$> v .:? "NumOfDiskSnapshots" pncSnapshotInterval <- Last . fmap RequestedSnapshotInterval <$> v .:? "SnapshotInterval" + pncDoDiskSnapshotChecksum + <- Last <$> v .:? "DoDiskSnapshotChecksum" pncExperimentalProtocolsEnabled <- fmap Last $ do mValue <- v .:? "ExperimentalProtocolsEnabled" @@ -301,13 +329,22 @@ instance FromJSON PartialNodeConfiguration where <- Last <$> v .:? "AcceptedConnectionsLimit" -- P2P Governor parameters, with conservative defaults. - pncTargetNumberOfRootPeers <- Last <$> v .:? "TargetNumberOfRootPeers" - pncTargetNumberOfKnownPeers <- Last <$> v .:? "TargetNumberOfKnownPeers" - pncTargetNumberOfEstablishedPeers <- Last <$> v .:? "TargetNumberOfEstablishedPeers" - pncTargetNumberOfActivePeers <- Last <$> v .:? "TargetNumberOfActivePeers" - pncTargetNumberOfKnownBigLedgerPeers <- Last <$> v .:? "TargetNumberOfKnownBigLedgerPeers" - pncTargetNumberOfEstablishedBigLedgerPeers <- Last <$> v .:? "TargetNumberOfEstablishedBigLedgerPeers" - pncTargetNumberOfActiveBigLedgerPeers <- Last <$> v .:? "TargetNumberOfActiveBigLedgerPeers" + pncDeadlineTargetOfRootPeers <- Last <$> v .:? "TargetNumberOfRootPeers" + pncDeadlineTargetOfKnownPeers <- Last <$> v .:? "TargetNumberOfKnownPeers" + pncDeadlineTargetOfEstablishedPeers <- Last <$> v .:? "TargetNumberOfEstablishedPeers" + pncDeadlineTargetOfActivePeers <- Last <$> v .:? "TargetNumberOfActivePeers" + pncDeadlineTargetOfKnownBigLedgerPeers <- Last <$> v .:? "TargetNumberOfKnownBigLedgerPeers" + pncDeadlineTargetOfEstablishedBigLedgerPeers <- Last <$> v .:? "TargetNumberOfEstablishedBigLedgerPeers" + pncDeadlineTargetOfActiveBigLedgerPeers <- Last <$> v .:? "TargetNumberOfActiveBigLedgerPeers" + pncSyncTargetOfActivePeers <- Last <$> v .:? "SyncTargetNumberOfActivePeers" + pncSyncTargetOfKnownBigLedgerPeers <- Last <$> v .:? "SyncTargetNumberOfKnownBigLedgerPeers" + pncSyncTargetOfEstablishedBigLedgerPeers <- Last <$> v .:? "SyncTargetNumberOfEstablishedBigLedgerPeers" + pncSyncTargetOfActiveBigLedgerPeers <- Last <$> v .:? "SyncTargetNumberOfActiveBigLedgerPeers" + -- Minimum number of active big ledger peers we must be connected to + -- in Genesis mode + pncMinBigLedgerPeersForTrustedState <- Last <$> v .:? "MinBigLedgerPeersForTrustedState" + + pncConsensusMode <- Last <$> v .:? "ConsensusMode" pncChainSyncIdleTimeout <- Last <$> v .:? "ChainSyncIdleTimeout" @@ -321,7 +358,7 @@ instance FromJSON PartialNodeConfiguration where -- Peer Sharing -- DISABLED BY DEFAULT - pncPeerSharing <- Last <$> v .:? "PeerSharing" .!= Just PeerSharingDisabled + pncPeerSharing <- Last <$> v .:? "PeerSharing" pure PartialNodeConfiguration { pncProtocolConfig @@ -329,6 +366,7 @@ instance FromJSON PartialNodeConfiguration where , pncDiffusionMode , pncNumOfDiskSnapshots , pncSnapshotInterval + , pncDoDiskSnapshotChecksum , pncExperimentalProtocolsEnabled , pncMaxConcurrencyBulkSync , pncMaxConcurrencyDeadline @@ -348,13 +386,19 @@ instance FromJSON PartialNodeConfiguration where , pncTimeWaitTimeout , pncChainSyncIdleTimeout , pncAcceptedConnectionsLimit - , pncTargetNumberOfRootPeers - , pncTargetNumberOfKnownPeers - , pncTargetNumberOfEstablishedPeers - , pncTargetNumberOfActivePeers - , pncTargetNumberOfKnownBigLedgerPeers - , pncTargetNumberOfEstablishedBigLedgerPeers - , pncTargetNumberOfActiveBigLedgerPeers + , pncDeadlineTargetOfRootPeers + , pncDeadlineTargetOfKnownPeers + , pncDeadlineTargetOfEstablishedPeers + , pncDeadlineTargetOfActivePeers + , pncDeadlineTargetOfKnownBigLedgerPeers + , pncDeadlineTargetOfEstablishedBigLedgerPeers + , pncDeadlineTargetOfActiveBigLedgerPeers + , pncSyncTargetOfActivePeers + , pncSyncTargetOfKnownBigLedgerPeers + , pncSyncTargetOfEstablishedBigLedgerPeers + , pncSyncTargetOfActiveBigLedgerPeers + , pncMinBigLedgerPeersForTrustedState + , pncConsensusMode , pncEnableP2P , pncPeerSharing } @@ -500,6 +544,7 @@ defaultPartialNodeConfiguration = , pncDiffusionMode = Last $ Just InitiatorAndResponderDiffusionMode , pncNumOfDiskSnapshots = Last $ Just DefaultNumOfDiskSnapshots , pncSnapshotInterval = Last $ Just DefaultSnapshotInterval + , pncDoDiskSnapshotChecksum = Last $ Just DoDiskSnapshotChecksum , pncExperimentalProtocolsEnabled = Last $ Just False , pncTopologyFile = Last . Just $ TopologyFile "configuration/cardano/mainnet-topology.json" , pncProtocolFiles = mempty @@ -523,17 +568,37 @@ defaultPartialNodeConfiguration = , acceptedConnectionsSoftLimit = 384 , acceptedConnectionsDelay = 5 } - , pncTargetNumberOfRootPeers = Last (Just 85) - , pncTargetNumberOfKnownPeers = Last (Just 85) - , pncTargetNumberOfEstablishedPeers = Last (Just 40) - , pncTargetNumberOfActivePeers = Last (Just 15) + , pncDeadlineTargetOfRootPeers = Last (Just deadlineRoots) + , pncDeadlineTargetOfKnownPeers = Last (Just deadlineKnown) + , pncDeadlineTargetOfEstablishedPeers = Last (Just deadlineEstablished) + , pncDeadlineTargetOfActivePeers = Last (Just deadlineActive) , pncChainSyncIdleTimeout = mempty - , pncTargetNumberOfKnownBigLedgerPeers = Last (Just 15) - , pncTargetNumberOfEstablishedBigLedgerPeers = Last (Just 10) - , pncTargetNumberOfActiveBigLedgerPeers = Last (Just 5) - , pncEnableP2P = Last (Just EnabledP2PMode) - , pncPeerSharing = Last (Just PeerSharingDisabled) + , pncDeadlineTargetOfKnownBigLedgerPeers = Last (Just deadlineBigKnown) + , pncDeadlineTargetOfEstablishedBigLedgerPeers = Last (Just deadlineBigEst) + , pncDeadlineTargetOfActiveBigLedgerPeers = Last (Just deadlineBigAct) + , pncSyncTargetOfActivePeers = Last (Just syncActive) + , pncSyncTargetOfKnownBigLedgerPeers = Last (Just syncBigKnown) + , pncSyncTargetOfEstablishedBigLedgerPeers = Last (Just syncBigEst) + , pncSyncTargetOfActiveBigLedgerPeers = Last (Just syncBigAct) + , pncMinBigLedgerPeersForTrustedState = Last (Just defaultMinBigLedgerPeersForTrustedState) + , pncConsensusMode = Last (Just defaultConsensusMode) + , pncEnableP2P = Last (Just EnabledP2PMode) + , pncPeerSharing = Last (Just defaultPeerSharing) } + where + Configuration.PeerSelectionTargets { + targetNumberOfRootPeers = deadlineRoots, + targetNumberOfKnownPeers = deadlineKnown, + targetNumberOfEstablishedPeers = deadlineEstablished, + targetNumberOfActivePeers = deadlineActive, + targetNumberOfKnownBigLedgerPeers = deadlineBigKnown, + targetNumberOfEstablishedBigLedgerPeers = deadlineBigEst, + targetNumberOfActiveBigLedgerPeers = deadlineBigAct } = defaultDeadlineTargets + Configuration.PeerSelectionTargets { + targetNumberOfActivePeers = syncActive, + targetNumberOfKnownBigLedgerPeers = syncBigKnown, + targetNumberOfEstablishedBigLedgerPeers = syncBigEst, + targetNumberOfActiveBigLedgerPeers = syncBigAct } = defaultSyncTargets lastOption :: Parser a -> Parser (Last a) lastOption = fmap Last . optional @@ -552,30 +617,49 @@ makeNodeConfiguration pnc = do diffusionMode <- lastToEither "Missing DiffusionMode" $ pncDiffusionMode pnc numOfDiskSnapshots <- lastToEither "Missing NumOfDiskSnapshots" $ pncNumOfDiskSnapshots pnc snapshotInterval <- lastToEither "Missing SnapshotInterval" $ pncSnapshotInterval pnc + doDiskSnapshotChecksum <- lastToEither "Missing DoDiskSnapshotChecksum" $ pncDoDiskSnapshotChecksum pnc shutdownConfig <- lastToEither "Missing ShutdownConfig" $ pncShutdownConfig pnc socketConfig <- lastToEither "Missing SocketConfig" $ pncSocketConfig pnc - ncTargetNumberOfRootPeers <- + ncDeadlineTargetOfRootPeers <- lastToEither "Missing TargetNumberOfRootPeers" - $ pncTargetNumberOfRootPeers pnc - ncTargetNumberOfKnownPeers <- + $ pncDeadlineTargetOfRootPeers pnc + ncDeadlineTargetOfKnownPeers <- lastToEither "Missing TargetNumberOfKnownPeers" - $ pncTargetNumberOfKnownPeers pnc - ncTargetNumberOfEstablishedPeers <- + $ pncDeadlineTargetOfKnownPeers pnc + ncDeadlineTargetOfEstablishedPeers <- lastToEither "Missing TargetNumberOfEstablishedPeers" - $ pncTargetNumberOfEstablishedPeers pnc - ncTargetNumberOfActivePeers <- + $ pncDeadlineTargetOfEstablishedPeers pnc + ncDeadlineTargetOfActivePeers <- lastToEither "Missing TargetNumberOfActivePeers" - $ pncTargetNumberOfActivePeers pnc - ncTargetNumberOfKnownBigLedgerPeers <- + $ pncDeadlineTargetOfActivePeers pnc + ncDeadlineTargetOfKnownBigLedgerPeers <- lastToEither "Missing TargetNumberOfKnownBigLedgerPeers" - $ pncTargetNumberOfKnownBigLedgerPeers pnc - ncTargetNumberOfEstablishedBigLedgerPeers <- + $ pncDeadlineTargetOfKnownBigLedgerPeers pnc + ncDeadlineTargetOfEstablishedBigLedgerPeers <- lastToEither "Missing TargetNumberOfEstablishedBigLedgerPeers" - $ pncTargetNumberOfEstablishedBigLedgerPeers pnc - ncTargetNumberOfActiveBigLedgerPeers <- + $ pncDeadlineTargetOfEstablishedBigLedgerPeers pnc + ncDeadlineTargetOfActiveBigLedgerPeers <- lastToEither "Missing TargetNumberOfActiveBigLedgerPeers" - $ pncTargetNumberOfActiveBigLedgerPeers pnc + $ pncDeadlineTargetOfActiveBigLedgerPeers pnc + ncSyncTargetOfActivePeers <- + lastToEither "Missing SyncTargetNumberOfActivePeers" + $ pncSyncTargetOfActivePeers pnc + ncSyncTargetOfKnownBigLedgerPeers <- + lastToEither "Missing SyncTargetNumberOfKnownBigLedgerPeers" + $ pncSyncTargetOfKnownBigLedgerPeers pnc + ncSyncTargetOfEstablishedBigLedgerPeers <- + lastToEither "Missing SyncTargetNumberOfEstablishedBigLedgerPeers" + $ pncSyncTargetOfEstablishedBigLedgerPeers pnc + ncSyncTargetOfActiveBigLedgerPeers <- + lastToEither "Missing SyncTargetNumberOfActiveBigLedgerPeers" + $ pncSyncTargetOfActiveBigLedgerPeers pnc + ncMinBigLedgerPeersForTrustedState <- + lastToEither "Missing MinBigLedgerPeersForTrustedState" + $ pncMinBigLedgerPeersForTrustedState pnc + ncConsensusMode <- + lastToEither "Missing ConsensusMode" + $ pncConsensusMode pnc ncProtocolIdleTimeout <- lastToEither "Missing ProtocolIdleTimeout" $ pncProtocolIdleTimeout pnc @@ -621,6 +705,7 @@ makeNodeConfiguration pnc = do , ncDiffusionMode = diffusionMode , ncNumOfDiskSnapshots = numOfDiskSnapshots , ncSnapshotInterval = snapshotInterval + , ncDoDiskSnapshotChecksum = doDiskSnapshotChecksum , ncExperimentalProtocolsEnabled = experimentalProtocols , ncMaxConcurrencyBulkSync = getLast $ pncMaxConcurrencyBulkSync pnc , ncMaxConcurrencyDeadline = getLast $ pncMaxConcurrencyDeadline pnc @@ -634,17 +719,23 @@ makeNodeConfiguration pnc = do , ncTimeWaitTimeout , ncChainSyncIdleTimeout , ncAcceptedConnectionsLimit - , ncTargetNumberOfRootPeers - , ncTargetNumberOfKnownPeers - , ncTargetNumberOfEstablishedPeers - , ncTargetNumberOfActivePeers - , ncTargetNumberOfKnownBigLedgerPeers - , ncTargetNumberOfEstablishedBigLedgerPeers - , ncTargetNumberOfActiveBigLedgerPeers + , ncDeadlineTargetOfRootPeers + , ncDeadlineTargetOfKnownPeers + , ncDeadlineTargetOfEstablishedPeers + , ncDeadlineTargetOfActivePeers + , ncDeadlineTargetOfKnownBigLedgerPeers + , ncDeadlineTargetOfEstablishedBigLedgerPeers + , ncDeadlineTargetOfActiveBigLedgerPeers + , ncSyncTargetOfActivePeers + , ncSyncTargetOfKnownBigLedgerPeers + , ncSyncTargetOfEstablishedBigLedgerPeers + , ncSyncTargetOfActiveBigLedgerPeers + , ncMinBigLedgerPeersForTrustedState , ncEnableP2P = case enableP2P of EnabledP2PMode -> SomeNetworkP2PMode Consensus.EnabledP2PMode DisabledP2PMode -> SomeNetworkP2PMode Consensus.DisabledP2PMode , ncPeerSharing + , ncConsensusMode } ncProtocol :: NodeConfiguration -> Protocol diff --git a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs index dfad181fa7f..2e7517bf31e 100644 --- a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs +++ b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} @@ -17,6 +18,7 @@ module Cardano.Node.Configuration.TopologyP2P , PeerAdvertise(..) , nodeAddressToSockAddr , readTopologyFile + , readPeerSnapshotFile , readTopologyFileOrError , rootConfigToRelayAccessPoint ) @@ -25,11 +27,14 @@ where import Cardano.Node.Configuration.NodeAddress import Cardano.Node.Configuration.POM (NodeConfiguration (..)) import Cardano.Node.Configuration.Topology (TopologyError (..)) +import Cardano.Node.Startup (StartupTrace (..)) import Cardano.Node.Types import Cardano.Tracing.OrphanInstances.Network () -import Ouroboros.Network.NodeToNode (PeerAdvertise (..)) +import Ouroboros.Network.ConsensusMode +import Ouroboros.Network.NodeToNode (DiffusionMode (..), PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers (..)) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot (..), + UseLedgerPeers (..)) import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), @@ -39,6 +44,8 @@ import Control.Applicative (Alternative (..)) import Control.Exception (IOException) import qualified Control.Exception as Exception import Control.Exception.Base (Exception (..)) +import Control.Monad.Trans.Except.Extra +import qualified "contra-tracer" Control.Tracer as CT import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as LBS @@ -105,7 +112,7 @@ instance ToJSON RootConfig where rootConfigToRelayAccessPoint :: RootConfig -> [(RelayAccessPoint, PeerAdvertise)] -rootConfigToRelayAccessPoint RootConfig { rootAccessPoints, rootAdvertise } = +rootConfigToRelayAccessPoint RootConfig { rootAccessPoints, rootAdvertise } = [ (ap, rootAdvertise) | ap <- rootAccessPoints ] @@ -122,6 +129,8 @@ data LocalRootPeersGroup = LocalRootPeersGroup , trustable :: PeerTrustable -- ^ 'trustable' configures whether the root should be trusted in fallback -- state. + , rootDiffusionMode :: DiffusionMode + -- ^ diffusion mode; used for local root peers. } deriving (Eq, Show) -- | Does not use the 'FromJSON' instance of 'RootConfig', so that @@ -136,6 +145,9 @@ instance FromJSON LocalRootPeersGroup where <*> pure hv <*> o .:? "warmValency" .!= WarmValency v <*> o .:? "trustable" .!= IsNotTrustable + -- deserialise via NodeDiffusionMode + <*> (maybe InitiatorAndResponderDiffusionMode getDiffusionMode + <$> o .:? "diffusionMode") instance ToJSON LocalRootPeersGroup where toJSON lrpg = @@ -145,6 +157,8 @@ instance ToJSON LocalRootPeersGroup where , "hotValency" .= hotValency lrpg , "warmValency" .= warmValency lrpg , "trustable" .= trustable lrpg + -- serialise via NodeDiffusionMode + , "diffusionMode" .= NodeDiffusionMode (rootDiffusionMode lrpg) ] newtype LocalRootPeersGroups = LocalRootPeersGroups @@ -171,6 +185,7 @@ data NetworkTopology = RealNodeTopology { ntLocalRootPeersGroups :: !LocalRootPe , ntPublicRootPeers :: ![PublicRootPeers] , ntUseLedgerPeers :: !UseLedgerPeers , ntUseBootstrapPeers :: !UseBootstrapPeers + , ntPeerSnapshotPath :: !(Maybe PeerSnapshotFile) } deriving (Eq, Show) @@ -179,7 +194,8 @@ instance FromJSON NetworkTopology where RealNodeTopology <$> (o .: "localRoots" ) <*> (o .: "publicRoots" ) <*> (o .:? "useLedgerAfterSlot" .!= DontUseLedgerPeers ) - <*> (o .:? "bootstrapPeers" .!= DontUseBootstrapPeers) + <*> (o .:? "bootstrapPeers" .!= DontUseBootstrapPeers ) + <*> (o .:? "peerSnapshotFile") instance ToJSON NetworkTopology where toJSON top = @@ -188,27 +204,36 @@ instance ToJSON NetworkTopology where , ntPublicRootPeers , ntUseLedgerPeers , ntUseBootstrapPeers + , ntPeerSnapshotPath } -> object [ "localRoots" .= ntLocalRootPeersGroups , "publicRoots" .= ntPublicRootPeers , "useLedgerAfterSlot" .= ntUseLedgerPeers , "bootstrapPeers" .= ntUseBootstrapPeers + , "peerSnapshotFile" .= ntPeerSnapshotPath ] -- | Read the `NetworkTopology` configuration from the specified file. -- -readTopologyFile :: NodeConfiguration -> IO (Either Text NetworkTopology) -readTopologyFile nc = do +readTopologyFile :: NodeConfiguration -> CT.Tracer IO (StartupTrace blk) -> IO (Either Text NetworkTopology) +readTopologyFile nc tr = do eBs <- Exception.try $ BS.readFile (unTopology $ ncTopologyFile nc) case eBs of Left e -> return . Left $ handler e Right bs -> let bs' = LBS.fromStrict bs in - return $ case eitherDecode bs' of - Left err -> Left (handlerJSON err) + case eitherDecode bs' of + Left err -> return $ Left (handlerJSON err) Right t - | isValidTrustedPeerConfiguration t -> Right t - | otherwise -> Left handlerBootstrap + | isValidTrustedPeerConfiguration t -> + if isGenesisCompatible (ncConsensusMode nc) (ntUseBootstrapPeers t) + then return (Right t) + else do + CT.traceWith tr $ + NetworkConfigUpdateError genesisIncompatible + return . Right $ t { ntUseBootstrapPeers = DontUseBootstrapPeers } + | otherwise -> + pure $ Left handlerBootstrap where handler :: IOException -> Text handler e = Text.pack $ "Cardano.Node.Configuration.Topology.readTopologyFile: " @@ -223,6 +248,9 @@ readTopologyFile nc = do , "configuration flag. " , Text.pack err ] + genesisIncompatible + = Text.pack $ "Cardano.Node.Configuration.Topology.readTopologyFile: " + <> "Bootstrap peers are not used in Genesis consensus mode." handlerBootstrap :: Text handlerBootstrap = mconcat [ "You seem to have not configured any trustable peers. " @@ -230,14 +258,22 @@ readTopologyFile nc = do , "in bootstrap mode. Make sure you provide at least one bootstrap peer " , "source. " ] + isGenesisCompatible GenesisMode (UseBootstrapPeers{}) = False + isGenesisCompatible _ _ = True -readTopologyFileOrError :: NodeConfiguration -> IO NetworkTopology -readTopologyFileOrError nc = - readTopologyFile nc +readTopologyFileOrError :: NodeConfiguration -> CT.Tracer IO (StartupTrace blk) -> IO NetworkTopology +readTopologyFileOrError nc tr = + readTopologyFile nc tr >>= either (\err -> error $ "Cardano.Node.Configuration.TopologyP2P.readTopologyFile: " <> Text.unpack err) pure +readPeerSnapshotFile :: PeerSnapshotFile -> IO LedgerPeerSnapshot +readPeerSnapshotFile (PeerSnapshotFile psf) = either error pure =<< runExceptT + (handleLeftT (left . ("Cardano.Node.Configuration.TopologyP2P.readPeerSnapshotFile: " <>)) $ do + bs <- BS.readFile psf `catchIOExceptT` displayException + hoistEither (eitherDecode . LBS.fromStrict $ bs)) + -- -- Checking for chance of progress in bootstrap phase -- @@ -245,17 +281,18 @@ readTopologyFileOrError nc = -- | This function returns false if non-trustable peers are configured -- isValidTrustedPeerConfiguration :: NetworkTopology -> Bool -isValidTrustedPeerConfiguration (RealNodeTopology (LocalRootPeersGroups lprgs) _ _ ubp) = +isValidTrustedPeerConfiguration (RealNodeTopology (LocalRootPeersGroups lprgs) _ _ ubp _) = case ubp of DontUseBootstrapPeers -> True UseBootstrapPeers [] -> anyTrustable UseBootstrapPeers (_:_) -> True where anyTrustable = - any (\(LocalRootPeersGroup lr _ _ pt) -> case pt of + any (\LocalRootPeersGroup {localRoots, trustable} -> + case trustable of IsNotTrustable -> False IsTrustable -> not . null . rootAccessPoints - $ lr + $ localRoots ) lprgs diff --git a/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs b/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs index ada94ad7427..11c8ad9f845 100644 --- a/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs +++ b/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs @@ -31,7 +31,6 @@ where import Cardano.Slotting.Slot (WithOrigin (..)) import Ouroboros.Consensus.Block (Header) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Consensus.Util.STM (Watcher (..), forkLinkedWatcher) import Ouroboros.Network.Block (BlockNo (..), HasHeader, SlotNo (..), pointSlot) @@ -40,6 +39,7 @@ import Control.DeepSeq (NFData) import Control.Exception (try) import Control.Exception.Base (throwIO) import Control.Monad (void, when) +import Control.ResourceRegistry (ResourceRegistry) import "contra-tracer" Control.Tracer import Data.Aeson (FromJSON, ToJSON) import Data.Foldable (asum) diff --git a/cardano-node/src/Cardano/Node/Orphans.hs b/cardano-node/src/Cardano/Node/Orphans.hs index b0246e0f6e7..eefa6e7b84b 100644 --- a/cardano-node/src/Cardano/Node/Orphans.hs +++ b/cardano-node/src/Cardano/Node/Orphans.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} @@ -8,6 +10,7 @@ module Cardano.Node.Orphans () where import Cardano.Api () +import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag(..)) import Ouroboros.Consensus.Node import qualified Data.Text as Text import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..)) @@ -46,11 +49,14 @@ instance FromJSON AcceptedConnectionsLimit where <*> v .: "delay" instance FromJSON NodeDatabasePaths where - parseJSON o@(Object{})= - withObject "NodeDatabasePaths" + parseJSON o@(Object{})= + withObject "NodeDatabasePaths" (\v -> MultipleDbPaths <$> v .: "ImmutableDbPath" <*> v .: "VolatileDbPath" ) o parseJSON (String s) = return . OnePathForAllDbs $ Text.unpack s parseJSON _ = fail "NodeDatabasePaths must be an object or a string" + +deriving newtype instance FromJSON (Flag symbol) +deriving newtype instance ToJSON (Flag symbol) diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index d77bb991e28..8011e0e14c9 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -92,6 +92,7 @@ nodeRunParser = do , pncDiffusionMode = mempty , pncNumOfDiskSnapshots = numOfDiskSnapshots , pncSnapshotInterval = snapshotInterval + , pncDoDiskSnapshotChecksum = mempty , pncExperimentalProtocolsEnabled = mempty , pncProtocolFiles = Last $ Just ProtocolFilepaths { byronCertFile @@ -117,13 +118,19 @@ nodeRunParser = do , pncTimeWaitTimeout = mempty , pncChainSyncIdleTimeout = mempty , pncAcceptedConnectionsLimit = mempty - , pncTargetNumberOfRootPeers = mempty - , pncTargetNumberOfKnownPeers = mempty - , pncTargetNumberOfEstablishedPeers = mempty - , pncTargetNumberOfActivePeers = mempty - , pncTargetNumberOfKnownBigLedgerPeers = mempty - , pncTargetNumberOfEstablishedBigLedgerPeers = mempty - , pncTargetNumberOfActiveBigLedgerPeers = mempty + , pncDeadlineTargetOfRootPeers = mempty + , pncDeadlineTargetOfKnownPeers = mempty + , pncDeadlineTargetOfEstablishedPeers = mempty + , pncDeadlineTargetOfActivePeers = mempty + , pncDeadlineTargetOfKnownBigLedgerPeers = mempty + , pncDeadlineTargetOfEstablishedBigLedgerPeers = mempty + , pncDeadlineTargetOfActiveBigLedgerPeers = mempty + , pncSyncTargetOfActivePeers = mempty + , pncSyncTargetOfKnownBigLedgerPeers = mempty + , pncSyncTargetOfEstablishedBigLedgerPeers = mempty + , pncSyncTargetOfActiveBigLedgerPeers = mempty + , pncMinBigLedgerPeersForTrustedState = mempty + , pncConsensusMode = mempty , pncEnableP2P = mempty , pncPeerSharing = mempty } diff --git a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs index caa24132d04..e21687f0493 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs @@ -31,7 +31,6 @@ import Cardano.Tracing.OrphanInstances.Byron () import Cardano.Tracing.OrphanInstances.Shelley () import Ouroboros.Consensus.Cardano import qualified Ouroboros.Consensus.Cardano as Consensus -import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus import Ouroboros.Consensus.Cardano.Condense () import qualified Ouroboros.Consensus.Cardano.Node as Consensus import Ouroboros.Consensus.Config (emptyCheckpointsMap) @@ -91,17 +90,11 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { -- not-yet-ready eras in released node versions without mainnet nodes -- prematurely advertising that they could hard fork into the new era. npcTestShelleyHardForkAtEpoch, - npcTestShelleyHardForkAtVersion, npcTestAllegraHardForkAtEpoch, - npcTestAllegraHardForkAtVersion, npcTestMaryHardForkAtEpoch, - npcTestMaryHardForkAtVersion, npcTestAlonzoHardForkAtEpoch, - npcTestAlonzoHardForkAtVersion, npcTestBabbageHardForkAtEpoch, - npcTestBabbageHardForkAtVersion, - npcTestConwayHardForkAtEpoch, - npcTestConwayHardForkAtVersion + npcTestConwayHardForkAtEpoch } files = do byronGenesis <- @@ -171,7 +164,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { shelleyGenesisHash, shelleyBasedLeaderCredentials = shelleyLeaderCredentials } - , Consensus.cardanoProtocolVersion = ProtVer (natVersion @10) 0 + , Consensus.cardanoProtocolVersion = ProtVer (natVersion @10) 1 -- The remaining arguments specify the parameters needed to transition between two eras , Consensus.cardanoLedgerTransitionConfig = Ledger.mkLatestTransitionConfig @@ -202,37 +195,31 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { -- But we also provide an override to allow for simpler test setups -- such as triggering at the 0 -> 1 transition . -- - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 2 fromIntegral npcTestShelleyHardForkAtVersion) + Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion -- Alternatively, for testing we can transition at a specific epoch. -- - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo , triggerHardForkAllegra = case npcTestAllegraHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 3 fromIntegral npcTestAllegraHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion + Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo , triggerHardForkMary = case npcTestMaryHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 4 fromIntegral npcTestMaryHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion + Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo , triggerHardForkAlonzo = case npcTestAlonzoHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 5 fromIntegral npcTestAlonzoHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion + Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo , triggerHardForkBabbage = case npcTestBabbageHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 7 fromIntegral npcTestBabbageHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion + Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo , triggerHardForkConway = case npcTestConwayHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 9 fromIntegral npcTestConwayHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion + Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo } -- TODO: once https://github.com/IntersectMBO/cardano-node/issues/5730 is implemented 'emptyCheckpointsMap' needs to be replaced with the checkpoints map read from a configuration file. , Consensus.cardanoCheckpoints = emptyCheckpointsMap diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 3b88274a99e..9e1cc6f6966 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} @@ -63,7 +64,7 @@ import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) import Cardano.Tracing.Tracers import qualified Ouroboros.Consensus.Config as Consensus import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) -import Ouroboros.Consensus.Node (DiskPolicyArgs (..), NetworkP2PMode (..), +import Ouroboros.Consensus.Node (DiskPolicyArgs (..), pattern DoDiskSnapshotChecksum, pattern NoDoDiskSnapshotChecksum, NetworkP2PMode (..), NodeDatabasePaths (..), RunNodeArgs (..), StdRunNodeArgs (..)) import qualified Ouroboros.Consensus.Node as Node (NodeDatabasePaths (..), getChainDB, run) import Ouroboros.Consensus.Node.Genesis @@ -78,11 +79,11 @@ import Ouroboros.Network.NodeToClient (LocalAddress (..), LocalSocket import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), ConnectionId, PeerSelectionTargets (..), RemoteAddress) import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot(..), UseLedgerPeers) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) -import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, LocalRootConfig (..), WarmValency) import Ouroboros.Network.Protocol.ChainSync.Codec import Ouroboros.Network.Subscription (DnsSubscriptionTarget (..), IPSubscriptionTarget (..)) @@ -91,7 +92,7 @@ import Control.Concurrent (killThread, mkWeakThreadId, myThreadId) import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (try) import qualified Control.Exception as Exception -import Control.Monad (forM_, unless, void, when) +import Control.Monad (forM, forM_, unless, void, when) import Control.Monad.Class.MonadThrow (MonadThrow (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT, runExceptT) @@ -435,16 +436,24 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do nt@TopologyP2P.RealNodeTopology { ntUseLedgerPeers , ntUseBootstrapPeers - } <- TopologyP2P.readTopologyFileOrError nc + , ntPeerSnapshotPath + } <- TopologyP2P.readTopologyFileOrError nc (startupTracer tracers) let (localRoots, publicRoots) = producerAddresses nt traceWith (startupTracer tracers) $ NetworkConfig localRoots publicRoots ntUseLedgerPeers - localRootsVar <- newTVarIO localRoots - publicRootsVar <- newTVarIO publicRoots - useLedgerVar <- newTVarIO ntUseLedgerPeers + ntPeerSnapshotPath + localRootsVar <- newTVarIO localRoots + publicRootsVar <- newTVarIO publicRoots + useLedgerVar <- newTVarIO ntUseLedgerPeers useBootstrapVar <- newTVarIO ntUseBootstrapPeers + ledgerPeerSnapshotPathVar <- newTVarIO ntPeerSnapshotPath + ledgerPeerSnapshotVar <- newTVarIO =<< updateLedgerPeerSnapshot + (startupTracer tracers) + (readTVar ledgerPeerSnapshotPathVar) + (const . pure $ ()) + let nodeArgs = RunNodeArgs { rnGenesisConfig = disableGenesisConfig , rnTraceConsensus = consensusTracers tracers @@ -478,6 +487,11 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do updateTopologyConfiguration (startupTracer tracers) nc localRootsVar publicRootsVar useLedgerVar useBootstrapVar + ledgerPeerSnapshotPathVar + void $ updateLedgerPeerSnapshot + (startupTracer tracers) + (readTVar ledgerPeerSnapshotPathVar) + (writeTVar ledgerPeerSnapshotVar) traceWith (startupTracer tracers) (BlockForgingUpdate NotEffective) ) Nothing @@ -489,6 +503,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do (readTVar publicRootsVar) (readTVar useLedgerVar) (readTVar useBootstrapVar) + (readTVar ledgerPeerSnapshotVar) in Node.run nodeArgs { @@ -496,6 +511,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do -- reinstall `SIGHUP` handler installP2PSigHUPHandler (startupTracer tracers) blockType nc nodeKernel localRootsVar publicRootsVar useLedgerVar useBootstrapVar + ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar rnNodeKernelHook nodeArgs registry nodeKernel } StdRunNodeArgs @@ -650,6 +666,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do DiskPolicyArgs (ncSnapshotInterval nc) (ncNumOfDiskSnapshots nc) + (ncDoDiskSnapshotChecksum nc) -------------------------------------------------------------------------------- -- SIGHUP Handlers @@ -661,21 +678,28 @@ installP2PSigHUPHandler :: Tracer IO (StartupTrace blk) -> Api.BlockType blk -> NodeConfiguration -> NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk - -> StrictTVar IO [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + -> StrictTVar IO [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)] -> StrictTVar IO (Map RelayAccessPoint PeerAdvertise) -> StrictTVar IO UseLedgerPeers -> StrictTVar IO UseBootstrapPeers + -> StrictTVar IO (Maybe PeerSnapshotFile) + -> StrictTVar IO (Maybe LedgerPeerSnapshot) -> IO () #ifndef UNIX -installP2PSigHUPHandler _ _ _ _ _ _ _ _ = return () +installP2PSigHUPHandler _ _ _ _ _ _ _ _ _ _ = return () #else installP2PSigHUPHandler startupTracer blockType nc nodeKernel localRootsVar publicRootsVar useLedgerVar - useBootstrapPeersVar = + useBootstrapPeersVar ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar = void $ Signals.installHandler Signals.sigHUP (Signals.Catch $ do updateBlockForging startupTracer blockType nodeKernel nc - updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLedgerVar useBootstrapPeersVar + updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar + useLedgerVar useBootstrapPeersVar ledgerPeerSnapshotPathVar + void $ updateLedgerPeerSnapshot + startupTracer + (readTVar ledgerPeerSnapshotPathVar) + (writeTVar ledgerPeerSnapshotVar) ) Nothing #endif @@ -756,15 +780,16 @@ updateBlockForging startupTracer blockType nodeKernel nc = do updateTopologyConfiguration :: Tracer IO (StartupTrace blk) -> NodeConfiguration - -> StrictTVar IO [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + -> StrictTVar IO [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)] -> StrictTVar IO (Map RelayAccessPoint PeerAdvertise) -> StrictTVar IO UseLedgerPeers -> StrictTVar IO UseBootstrapPeers + -> StrictTVar IO (Maybe PeerSnapshotFile) -> IO () updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLedgerVar - useBootsrapPeersVar = do + useBootsrapPeersVar ledgerPeerSnapshotPathVar = do traceWith startupTracer NetworkConfigUpdate - result <- try $ readTopologyFileOrError nc + result <- try $ readTopologyFileOrError nc startupTracer case result of Left (FatalError err) -> traceWith startupTracer @@ -772,17 +797,31 @@ updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLed $ pack "Error reading topology configuration file:" <> err Right nt@RealNodeTopology { ntUseLedgerPeers , ntUseBootstrapPeers + , ntPeerSnapshotPath } -> do let (localRoots, publicRoots) = producerAddresses nt traceWith startupTracer - $ NetworkConfig localRoots publicRoots ntUseLedgerPeers + $ NetworkConfig localRoots publicRoots ntUseLedgerPeers ntPeerSnapshotPath atomically $ do writeTVar localRootsVar localRoots writeTVar publicRootsVar publicRoots writeTVar useLedgerVar ntUseLedgerPeers writeTVar useBootsrapPeersVar ntUseBootstrapPeers + writeTVar ledgerPeerSnapshotPathVar ntPeerSnapshotPath #endif +updateLedgerPeerSnapshot :: Tracer IO (StartupTrace blk) + -> STM IO (Maybe PeerSnapshotFile) + -> (Maybe LedgerPeerSnapshot -> STM IO ()) + -> IO (Maybe LedgerPeerSnapshot) +updateLedgerPeerSnapshot startupTracer readLedgerPeerPath writeVar = do + mPeerSnapshotFile <- atomically readLedgerPeerPath + mLedgerPeerSnapshot <- forM mPeerSnapshotFile $ \f -> do + lps@(LedgerPeerSnapshot (wOrigin, _)) <- readPeerSnapshotFile f + lps <$ traceWith startupTracer (LedgerPeerSnapshotLoaded wOrigin) + atomically . writeVar $ mLedgerPeerSnapshot + pure mLedgerPeerSnapshot + -------------------------------------------------------------------------------- -- Helper functions -------------------------------------------------------------------------------- @@ -843,51 +882,69 @@ checkVRFFilePermissions (File vrfPrivKey) = do mkP2PArguments :: NodeConfiguration - -> STM IO [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + -> STM IO [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)] -- ^ non-overlapping local root peers groups; the 'Int' denotes the -- valency of its group. -> STM IO (Map RelayAccessPoint PeerAdvertise) -> STM IO UseLedgerPeers -> STM IO UseBootstrapPeers + -> STM IO (Maybe LedgerPeerSnapshot) -> Diffusion.ExtraArguments 'Diffusion.P2P IO mkP2PArguments NodeConfiguration { - ncTargetNumberOfRootPeers, - ncTargetNumberOfKnownPeers, - ncTargetNumberOfEstablishedPeers, - ncTargetNumberOfActivePeers, - ncTargetNumberOfKnownBigLedgerPeers, - ncTargetNumberOfEstablishedBigLedgerPeers, - ncTargetNumberOfActiveBigLedgerPeers, + ncDeadlineTargetOfRootPeers, + ncDeadlineTargetOfKnownPeers, + ncDeadlineTargetOfEstablishedPeers, + ncDeadlineTargetOfActivePeers, + ncDeadlineTargetOfKnownBigLedgerPeers, + ncDeadlineTargetOfEstablishedBigLedgerPeers, + ncDeadlineTargetOfActiveBigLedgerPeers, + ncSyncTargetOfActivePeers, + ncSyncTargetOfKnownBigLedgerPeers, + ncSyncTargetOfEstablishedBigLedgerPeers, + ncSyncTargetOfActiveBigLedgerPeers, + ncMinBigLedgerPeersForTrustedState, ncProtocolIdleTimeout, ncTimeWaitTimeout, - ncPeerSharing + ncPeerSharing, + ncConsensusMode } daReadLocalRootPeers daReadPublicRootPeers daReadUseLedgerPeers - daReadUseBootstrapPeers = + daReadUseBootstrapPeers + daReadLedgerPeerSnapshot = Diffusion.P2PArguments P2P.ArgumentsExtra - { P2P.daPeerSelectionTargets + { P2P.daPeerTargets = Configuration.ConsensusModePeerTargets { + Configuration.deadlineTargets, + Configuration.syncTargets } , P2P.daReadLocalRootPeers , P2P.daReadPublicRootPeers , P2P.daReadUseLedgerPeers , P2P.daReadUseBootstrapPeers + , P2P.daReadLedgerPeerSnapshot , P2P.daProtocolIdleTimeout = ncProtocolIdleTimeout , P2P.daTimeWaitTimeout = ncTimeWaitTimeout - , P2P.daDeadlineChurnInterval = 3300 - , P2P.daBulkChurnInterval = 900 + , P2P.daDeadlineChurnInterval = Configuration.defaultDeadlineChurnInterval + , P2P.daBulkChurnInterval = Configuration.defaultBulkChurnInterval , P2P.daOwnPeerSharing = ncPeerSharing + , P2P.daConsensusMode = ncConsensusMode + , P2P.daMinBigLedgerPeersForTrustedState = ncMinBigLedgerPeersForTrustedState } where - daPeerSelectionTargets = PeerSelectionTargets { - targetNumberOfRootPeers = ncTargetNumberOfRootPeers, - targetNumberOfKnownPeers = ncTargetNumberOfKnownPeers, - targetNumberOfEstablishedPeers = ncTargetNumberOfEstablishedPeers, - targetNumberOfActivePeers = ncTargetNumberOfActivePeers, - targetNumberOfKnownBigLedgerPeers = ncTargetNumberOfKnownBigLedgerPeers, - targetNumberOfEstablishedBigLedgerPeers = ncTargetNumberOfEstablishedBigLedgerPeers, - targetNumberOfActiveBigLedgerPeers = ncTargetNumberOfActiveBigLedgerPeers + deadlineTargets = Configuration.defaultDeadlineTargets { + targetNumberOfRootPeers = ncDeadlineTargetOfRootPeers, + targetNumberOfKnownPeers = ncDeadlineTargetOfKnownPeers, + targetNumberOfEstablishedPeers = ncDeadlineTargetOfEstablishedPeers, + targetNumberOfActivePeers = ncDeadlineTargetOfActivePeers, + targetNumberOfKnownBigLedgerPeers = ncDeadlineTargetOfKnownBigLedgerPeers, + targetNumberOfEstablishedBigLedgerPeers = ncDeadlineTargetOfEstablishedBigLedgerPeers, + targetNumberOfActiveBigLedgerPeers = ncDeadlineTargetOfActiveBigLedgerPeers } + syncTargets = Configuration.defaultSyncTargets { + targetNumberOfActivePeers = ncSyncTargetOfActivePeers, + targetNumberOfKnownBigLedgerPeers = ncSyncTargetOfKnownBigLedgerPeers, + targetNumberOfEstablishedBigLedgerPeers = ncSyncTargetOfEstablishedBigLedgerPeers, + targetNumberOfActiveBigLedgerPeers = ncSyncTargetOfActiveBigLedgerPeers } mkNonP2PArguments :: IPSubscriptionTarget @@ -921,18 +978,32 @@ producerAddressesNonP2P nt = producerAddresses :: NetworkTopology - -> ( [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] - , Map RelayAccessPoint PeerAdvertise) + -> ( [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)] + , Map RelayAccessPoint PeerAdvertise + ) + -- ^ local roots & public roots producerAddresses RealNodeTopology { ntLocalRootPeersGroups , ntPublicRootPeers } = ( map (\lrp -> ( hotValency lrp , warmValency lrp - , Map.fromList $ map (fmap (, trustable lrp)) - $ rootConfigToRelayAccessPoint - $ localRoots lrp + , Map.fromList + . map (\(addr, peerAdvertise) -> + ( addr + , LocalRootConfig { + diffusionMode = rootDiffusionMode lrp, + peerAdvertise, + peerTrustable = trustable lrp + } + ) + ) + . rootConfigToRelayAccessPoint + $ localRoots lrp ) ) (groups ntLocalRootPeersGroups) - , foldMap (Map.fromList . rootConfigToRelayAccessPoint . publicRoots) ntPublicRootPeers + , foldMap ( Map.fromList + . rootConfigToRelayAccessPoint + . publicRoots + ) ntPublicRootPeers ) diff --git a/cardano-node/src/Cardano/Node/Startup.hs b/cardano-node/src/Cardano/Node/Startup.hs index 9f75890bafc..420ff47d5ac 100644 --- a/cardano-node/src/Cardano/Node/Startup.hs +++ b/cardano-node/src/Cardano/Node/Startup.hs @@ -19,6 +19,8 @@ import Cardano.Node.Configuration.POM (NodeConfiguration (..), ncProto import Cardano.Node.Configuration.Socket import Cardano.Node.Protocol (ProtocolInstantiationError) import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) +import Cardano.Node.Types (PeerSnapshotFile) +import Cardano.Slotting.Slot (SlotNo, WithOrigin) import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as WCT import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.CanHardFork (shelleyLedgerConfig) @@ -34,9 +36,8 @@ import Ouroboros.Network.NodeToClient (LocalAddress (..), LocalSocket, NodeToClientVersion) import Ouroboros.Network.NodeToNode (DiffusionMode (..), NodeToNodeVersion, PeerAdvertise) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers) -import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) -import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, LocalRootConfig, WarmValency) import Ouroboros.Network.Subscription.Dns (DnsSubscriptionTarget (..)) import Ouroboros.Network.Subscription.Ip (IPSubscriptionTarget (..)) @@ -106,9 +107,10 @@ data StartupTrace blk = -- | Log peer-to-peer network configuration, either on startup or when its -- updated. -- - | NetworkConfig [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + | NetworkConfig [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)] (Map RelayAccessPoint PeerAdvertise) UseLedgerPeers + (Maybe PeerSnapshotFile) -- | Warn when 'DisabledP2P' is set. | NonP2PWarning @@ -127,6 +129,7 @@ data StartupTrace blk = | BIShelley BasicInfoShelleyBased | BIByron BasicInfoByron | BINetwork BasicInfoNetwork + | LedgerPeerSnapshotLoaded (WithOrigin SlotNo) data EnabledBlockForging = EnabledBlockForging | DisabledBlockForging diff --git a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs index a2e4aa6bb35..2ff5e336903 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs @@ -53,11 +53,10 @@ import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch import Ouroboros.Network.BlockFetch.Decision import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) import Ouroboros.Network.ConnectionId (ConnectionId) -import Ouroboros.Network.ConnectionManager.Types (ConnectionManagerTrace (..)) +import qualified Ouroboros.Network.ConnectionManager.Core as ConnectionManager import qualified Ouroboros.Network.ConnectionManager.Types as ConnectionManager import qualified Ouroboros.Network.Diffusion as Diffusion import Ouroboros.Network.Driver.Simple (TraceSendRecv) -import Ouroboros.Network.InboundGovernor (InboundGovernorTrace) import qualified Ouroboros.Network.InboundGovernor as InboundGovernor import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) import qualified Ouroboros.Network.NodeToClient as NtC @@ -79,7 +78,7 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type (LocalStateQuer import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LTM import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) -import Ouroboros.Network.Server2 (ServerTrace (..)) +import qualified Ouroboros.Network.Server2 as Server (Trace (..)) import Ouroboros.Network.Snocket (LocalAddress (..)) import Ouroboros.Network.Subscription.Dns (DnsTrace (..), WithDomainName (..)) import Ouroboros.Network.Subscription.Worker (SubscriptionTrace (..)) @@ -88,7 +87,7 @@ import Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbo import Control.Exception (SomeException) import qualified Data.Text as T -import Network.Mux (MuxTrace (..), WithMuxBearer (..)) +import qualified Network.Mux as Mux import qualified Network.Socket as Socket @@ -244,10 +243,10 @@ getAllNamespaces = dtMuxNS = map (nsGetTuple . nsReplacePrefix ["Net", "Mux", "Remote"]) (allNamespaces :: [Namespace - (WithMuxBearer (ConnectionId RemoteAddress) MuxTrace)]) + (Mux.WithBearer (ConnectionId RemoteAddress) Mux.Trace)]) dtLocalMuxNS = map (nsGetTuple . nsReplacePrefix ["Net", "Mux", "Local"]) (allNamespaces :: [Namespace - (WithMuxBearer (ConnectionId LocalAddress) MuxTrace)]) + (Mux.WithBearer (ConnectionId LocalAddress) Mux.Trace)]) dtHandshakeNS = map (nsGetTuple . nsReplacePrefix ["Net", "Handshake", "Remote"]) (allNamespaces :: [Namespace @@ -301,7 +300,7 @@ getAllNamespaces = connectionManagerNS = map (nsGetTuple . nsReplacePrefix ["Net", "ConnectionManager", "Remote"]) (allNamespaces :: [Namespace - (ConnectionManagerTrace + (ConnectionManager.Trace Socket.SockAddr (ConnectionHandlerTrace UnversionedProtocol @@ -313,11 +312,11 @@ getAllNamespaces = Socket.SockAddr)]) serverNS = map (nsGetTuple . nsReplacePrefix ["Net", "Server", "Remote"]) - (allNamespaces :: [Namespace (ServerTrace Socket.SockAddr)]) + (allNamespaces :: [Namespace (Server.Trace Socket.SockAddr)]) inboundGovernorNS = map (nsGetTuple . nsReplacePrefix ["Net", "InboundGovernor", "Remote"]) (allNamespaces :: [Namespace - (InboundGovernorTrace Socket.SockAddr)]) + (InboundGovernor.Trace Socket.SockAddr)]) inboundGovernorTransitionsNS = map (nsGetTuple . nsReplacePrefix ["Net", "InboundGovernor", "Transition"]) (allNamespaces :: [Namespace @@ -325,7 +324,7 @@ getAllNamespaces = localConnectionManagerNS = map (nsGetTuple . nsReplacePrefix ["Net", "ConnectionManager", "Local"]) (allNamespaces :: [Namespace - (ConnectionManagerTrace + (ConnectionManager.Trace Socket.SockAddr (ConnectionHandlerTrace UnversionedProtocol @@ -333,11 +332,11 @@ getAllNamespaces = localServerNS = map (nsGetTuple . nsReplacePrefix ["Net", "Server", "Local"]) (allNamespaces :: [Namespace - (ServerTrace LocalAddress)]) + (Server.Trace LocalAddress)]) localInboundGovernorNS = map (nsGetTuple . nsReplacePrefix ["Net", "InboundGovernor", "Local"]) (allNamespaces :: [Namespace - (InboundGovernorTrace LocalAddress)]) + (InboundGovernor.Trace LocalAddress)]) -- -- DiffusionTracersExtra nonP2P diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index e217afba03d..7d207e35d9b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -18,7 +18,7 @@ module Cardano.Node.Tracing.Documentation , docTracersFirstPhase ) where -import Cardano.Logging +import Cardano.Logging as Logging import Cardano.Logging.Resources import Cardano.Logging.Resources.Types () import Cardano.Node.Handlers.Shutdown (ShutdownTrace) @@ -61,11 +61,10 @@ import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch import Ouroboros.Network.BlockFetch.Decision import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) import Ouroboros.Network.ConnectionId (ConnectionId) -import Ouroboros.Network.ConnectionManager.Types (ConnectionManagerTrace (..)) +import qualified Ouroboros.Network.ConnectionManager.Core as ConnectionManager import qualified Ouroboros.Network.ConnectionManager.Types as ConnectionManager import qualified Ouroboros.Network.Diffusion as Diffusion import Ouroboros.Network.Driver.Simple (TraceSendRecv) -import Ouroboros.Network.InboundGovernor (InboundGovernorTrace) import qualified Ouroboros.Network.InboundGovernor as InboundGovernor import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) import qualified Ouroboros.Network.NodeToClient as NtC @@ -87,7 +86,7 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type (LocalStateQuer import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LTM import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) -import Ouroboros.Network.Server2 (ServerTrace (..)) +import qualified Ouroboros.Network.Server2 as Server (Trace (..)) import Ouroboros.Network.Snocket (LocalAddress (..)) import Ouroboros.Network.Subscription.Dns (DnsTrace (..), WithDomainName (..)) import Ouroboros.Network.Subscription.Ip (WithIPList (..)) @@ -101,7 +100,7 @@ import Data.Aeson.Types (ToJSON) import Data.Proxy (Proxy (..)) import qualified Data.Text.IO as T import GHC.Generics (Generic) -import Network.Mux (MuxTrace (..), WithMuxBearer (..)) +import qualified Network.Mux as Mux import qualified Network.Socket as Socket import qualified Options.Applicative as Opt import System.IO @@ -185,10 +184,10 @@ docTracersFirstPhase condConfigFileName = do trConfig <- case condConfigFileName of Just fn -> readConfigurationWithDefault fn defaultCardanoConfig Nothing -> pure defaultCardanoConfig - let trBase :: Trace IO FormattedMessage = docTracer (Stdout MachineFormat) - trForward :: Trace IO FormattedMessage = docTracer Forwarder + let trBase :: Logging.Trace IO FormattedMessage = docTracer (Stdout MachineFormat) + trForward :: Logging.Trace IO FormattedMessage = docTracer Forwarder trDataPoint = docTracerDatapoint DatapointBackend - mbTrEKG :: Maybe (Trace IO FormattedMessage) = Just (docTracer EKGBackend) + mbTrEKG :: Maybe (Logging.Trace IO FormattedMessage) = Just (docTracer EKGBackend) configReflection <- emptyConfigReflection @@ -196,53 +195,53 @@ docTracersFirstPhase condConfigFileName = do nodeInfoDp <- mkDataPointTracer trDataPoint configureTracers configReflection trConfig [nodeInfoDp] - nodeInfoDpDoc <- documentTracer (nodeInfoDp :: Trace IO NodeInfo) + nodeInfoDpDoc <- documentTracer (nodeInfoDp :: Logging.Trace IO NodeInfo) nodeStartupInfoDp <- mkDataPointTracer trDataPoint configureTracers configReflection trConfig [nodeStartupInfoDp] nodeStartupInfoDpDoc <- documentTracer - (nodeStartupInfoDp :: Trace IO NodeStartupInfo) + (nodeStartupInfoDp :: Logging.Trace IO NodeStartupInfo) nodeVersionTr <- mkCardanoTracer trBase trForward mbTrEKG ["Version"] configureTracers configReflection trConfig [nodeVersionTr] - nodeVersionDoc <- documentTracer (nodeVersionTr :: Trace IO NodeVersionTrace) + nodeVersionDoc <- documentTracer (nodeVersionTr :: Logging.Trace IO NodeVersionTrace) -- State tracer stateTr <- mkCardanoTracer trBase trForward mbTrEKG ["NodeState"] configureTracers configReflection trConfig [stateTr] - stateTrDoc <- documentTracer (stateTr :: Trace IO SR.NodeState) + stateTrDoc <- documentTracer (stateTr :: Logging.Trace IO SR.NodeState) -- Peers tracer peersTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "Peers", "List"] configureTracers configReflection trConfig [peersTr] - peersTrDoc <- documentTracer (peersTr :: Trace IO [PeerT blk]) + peersTrDoc <- documentTracer (peersTr :: Logging.Trace IO [PeerT blk]) -- Resource tracer resourcesTr <- mkCardanoTracer trBase trForward mbTrEKG [] configureTracers configReflection trConfig [resourcesTr] - resourcesTrDoc <- documentTracer (resourcesTr :: Trace IO ResourceStats) + resourcesTrDoc <- documentTracer (resourcesTr :: Logging.Trace IO ResourceStats) -- Startup tracer startupTr <- mkCardanoTracer trBase trForward mbTrEKG ["Startup"] configureTracers configReflection trConfig [startupTr] - startupTrDoc <- documentTracer (startupTr :: Trace IO (StartupTrace blk)) + startupTrDoc <- documentTracer (startupTr :: Logging.Trace IO (StartupTrace blk)) shutdownTr <- mkCardanoTracer trBase trForward mbTrEKG ["Shutdown"] configureTracers configReflection trConfig [shutdownTr] - shutdownTrDoc <- documentTracer (shutdownTr :: Trace IO ShutdownTrace) + shutdownTrDoc <- documentTracer (shutdownTr :: Logging.Trace IO ShutdownTrace) chainDBTr <- mkCardanoTracer' trBase trForward mbTrEKG @@ -250,13 +249,13 @@ docTracersFirstPhase condConfigFileName = do withAddedToCurrentChainEmptyLimited configureTracers configReflection trConfig [chainDBTr] chainDBTrDoc <- documentTracer (chainDBTr :: - Trace IO (ChainDB.TraceEvent blk)) + Logging.Trace IO (ChainDB.TraceEvent blk)) replayBlockTr <- mkCardanoTracer trBase trForward mbTrEKG ["ChainDB", "ReplayBlock"] configureTracers configReflection trConfig [replayBlockTr] - replayBlockTrDoc <- documentTracer (replayBlockTr :: Trace IO ReplayBlockStats) + replayBlockTrDoc <- documentTracer (replayBlockTr :: Logging.Trace IO ReplayBlockStats) -- Consensus tracers @@ -265,7 +264,7 @@ docTracersFirstPhase condConfigFileName = do ["ChainSync", "Client"] configureTracers configReflection trConfig [chainSyncClientTr] chainSyncClientTrDoc <- documentTracer (chainSyncClientTr :: - (Trace IO (BlockFetch.TraceLabelPeer + (Logging.Trace IO (BlockFetch.TraceLabelPeer (ConnectionId RemoteAddress) (TraceChainSyncClientEvent blk)))) @@ -274,21 +273,21 @@ docTracersFirstPhase condConfigFileName = do ["ChainSync", "ServerHeader"] configureTracers configReflection trConfig [chainSyncServerHeaderTr] chainSyncServerHeaderTrDoc <- documentTracer (chainSyncServerHeaderTr :: - (Trace IO (TraceChainSyncServerEvent blk))) + (Logging.Trace IO (TraceChainSyncServerEvent blk))) chainSyncServerBlockTr <- mkCardanoTracer trBase trForward mbTrEKG ["ChainSync", "ServerBlock"] configureTracers configReflection trConfig [chainSyncServerBlockTr] chainSyncServerBlockTrDoc <- documentTracer (chainSyncServerBlockTr :: - (Trace IO (TraceChainSyncServerEvent blk))) + (Logging.Trace IO (TraceChainSyncServerEvent blk))) blockFetchDecisionTr <- mkCardanoTracer trBase trForward mbTrEKG ["BlockFetch", "Decision"] configureTracers configReflection trConfig [blockFetchDecisionTr] blockFetchDecisionTrDoc <- documentTracer (blockFetchDecisionTr :: - Trace IO [BlockFetch.TraceLabelPeer + Logging.Trace IO [BlockFetch.TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]) @@ -297,7 +296,7 @@ docTracersFirstPhase condConfigFileName = do ["BlockFetch", "Client"] configureTracers configReflection trConfig [blockFetchClientTr] blockFetchClientTrDoc <- documentTracer (blockFetchClientTr :: - Trace IO (BlockFetch.TraceLabelPeer + Logging.Trace IO (BlockFetch.TraceLabelPeer remotePeer (BlockFetch.TraceFetchClientState (Header blk)))) @@ -307,28 +306,28 @@ docTracersFirstPhase condConfigFileName = do configureTracers configReflection trConfig [blockFetchClientMetricsTr] blockFetchClientMetricsDoc <- documentTracer (blockFetchClientMetricsTr :: - Trace IO ClientMetrics) + Logging.Trace IO ClientMetrics) blockFetchServerTr <- mkCardanoTracer trBase trForward mbTrEKG ["BlockFetch", "Server"] configureTracers configReflection trConfig [blockFetchServerTr] blockFetchServerTrDoc <- documentTracer (blockFetchServerTr :: - Trace IO (TraceBlockFetchServerEvent blk)) + Logging.Trace IO (TraceBlockFetchServerEvent blk)) forgeKESInfoTr <- mkCardanoTracer trBase trForward mbTrEKG ["Forge"] configureTracers configReflection trConfig [forgeKESInfoTr] forgeKESInfoTrDoc <- documentTracer (forgeKESInfoTr :: - Trace IO (Consensus.TraceLabelCreds HotKey.KESInfo)) + Logging.Trace IO (Consensus.TraceLabelCreds HotKey.KESInfo)) txInboundTr <- mkCardanoTracer trBase trForward mbTrEKG ["TxSubmission", "TxInbound"] configureTracers configReflection trConfig [txInboundTr] txInboundTrDoc <- documentTracer (txInboundTr :: - Trace IO (BlockFetch.TraceLabelPeer + Logging.Trace IO (BlockFetch.TraceLabelPeer remotePeer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) @@ -337,7 +336,7 @@ docTracersFirstPhase condConfigFileName = do ["TxSubmission", "TxOutbound"] configureTracers configReflection trConfig [txOutboundTr] txOutboundTrDoc <- documentTracer (txOutboundTr :: - Trace IO (BlockFetch.TraceLabelPeer + Logging.Trace IO (BlockFetch.TraceLabelPeer remotePeer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))) @@ -346,21 +345,21 @@ docTracersFirstPhase condConfigFileName = do ["TxSubmission", "LocalServer"] configureTracers configReflection trConfig [localTxSubmissionServerTr] localTxSubmissionServerTrDoc <- documentTracer (localTxSubmissionServerTr :: - Trace IO (TraceLocalTxSubmissionServerEvent blk)) + Logging.Trace IO (TraceLocalTxSubmissionServerEvent blk)) mempoolTr <- mkCardanoTracer trBase trForward mbTrEKG ["Mempool"] configureTracers configReflection trConfig [mempoolTr] mempoolTrDoc <- documentTracer (mempoolTr :: - Trace IO (TraceEventMempool blk)) + Logging.Trace IO (TraceEventMempool blk)) forgeTr <- mkCardanoTracer trBase trForward mbTrEKG ["Forge", "Loop"] configureTracers configReflection trConfig [forgeTr] forgeTrDoc <- documentTracer (forgeTr :: - Trace IO (ForgeTracerType blk)) + Logging.Trace IO (ForgeTracerType blk)) forgeTr' <- mkCardanoTracer @@ -368,14 +367,14 @@ docTracersFirstPhase condConfigFileName = do ["Forge", "ThreadStats"] configureTracers configReflection trConfig [forgeTr'] forgeThreadStatsTrDoc <- documentTracer (forgeTr' :: - Trace IO ForgeThreadStats) + Logging.Trace IO ForgeThreadStats) blockchainTimeTr <- mkCardanoTracer trBase trForward mbTrEKG ["BlockchainTime"] configureTracers configReflection trConfig [blockchainTimeTr] blockchainTimeTrDoc <- documentTracer (blockchainTimeTr :: - Trace IO (TraceBlockchainTimeEvent RelativeTime)) + Logging.Trace IO (TraceBlockchainTimeEvent RelativeTime)) -- Node to client @@ -384,14 +383,14 @@ docTracersFirstPhase condConfigFileName = do ["Net"] configureTracers configReflection trConfig [keepAliveClientTr] keepAliveClientTrDoc <- documentTracer (keepAliveClientTr :: - Trace IO (TraceKeepAliveClient peer)) + Logging.Trace IO (TraceKeepAliveClient peer)) chainSyncTr <- mkCardanoTracer trBase trForward mbTrEKG ["ChainSync", "Local"] configureTracers configReflection trConfig [chainSyncTr] chainSyncTrDoc <- documentTracer (chainSyncTr :: - Trace IO + Logging.Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))) @@ -401,7 +400,7 @@ docTracersFirstPhase condConfigFileName = do ["TxSubmission", "MonitorClient"] configureTracers configReflection trConfig [txMonitorTr] txMonitorTrDoc <- documentTracer (txMonitorTr :: - Trace IO + Logging.Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv @@ -413,7 +412,7 @@ docTracersFirstPhase condConfigFileName = do ["TxSubmission", "Local"] configureTracers configReflection trConfig [txSubmissionTr] txSubmissionTrDoc <- documentTracer (txSubmissionTr :: - Trace IO + Logging.Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv @@ -425,7 +424,7 @@ docTracersFirstPhase condConfigFileName = do ["StateQueryServer"] configureTracers configReflection trConfig [stateQueryTr] stateQueryTrDoc <- documentTracer (stateQueryTr :: - Trace IO + Logging.Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))) @@ -437,7 +436,7 @@ docTracersFirstPhase condConfigFileName = do ["ChainSync", "Remote"] configureTracers configReflection trConfig [chainSyncNodeTr] chainSyncNodeTrDoc <- documentTracer (chainSyncNodeTr :: - Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv + Logging.Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))) chainSyncSerialisedTr <- mkCardanoTracer @@ -445,7 +444,7 @@ docTracersFirstPhase condConfigFileName = do ["ChainSync", "Remote", "Serialised"] configureTracers configReflection trConfig [chainSyncSerialisedTr] chainSyncSerialisedTrDoc <- documentTracer (chainSyncSerialisedTr :: - Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv + Logging.Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))) blockFetchTr <- mkCardanoTracer @@ -453,7 +452,7 @@ docTracersFirstPhase condConfigFileName = do ["BlockFetch", "Remote"] configureTracers configReflection trConfig [blockFetchTr] blockFetchTrDoc <- documentTracer (blockFetchTr :: - Trace IO + Logging.Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))) @@ -463,7 +462,7 @@ docTracersFirstPhase condConfigFileName = do ["BlockFetch", "Remote", "Serialised"] configureTracers configReflection trConfig [blockFetchSerialisedTr] blockFetchSerialisedTrDoc <- documentTracer (blockFetchSerialisedTr :: - Trace IO + Logging.Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))) @@ -473,7 +472,7 @@ docTracersFirstPhase condConfigFileName = do ["TxSubmission", "Remote"] configureTracers configReflection trConfig [txSubmission2Tr] txSubmission2TrDoc <- documentTracer (txSubmission2Tr :: - Trace IO + Logging.Trace IO (BlockFetch.TraceLabelPeer peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk))))) @@ -484,28 +483,28 @@ docTracersFirstPhase condConfigFileName = do ["Net", "Mux", "Remote"] configureTracers configReflection trConfig [dtMuxTr] dtMuxTrDoc <- documentTracer (dtMuxTr :: - Trace IO (WithMuxBearer (ConnectionId RemoteAddress) MuxTrace)) + Logging.Trace IO (Mux.WithBearer (ConnectionId RemoteAddress) Mux.Trace)) dtLocalMuxTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "Mux", "Local"] configureTracers configReflection trConfig [dtLocalMuxTr] dtLocalMuxTrDoc <- documentTracer (dtLocalMuxTr :: - Trace IO (WithMuxBearer (ConnectionId LocalAddress) MuxTrace)) + Logging.Trace IO (Mux.WithBearer (ConnectionId LocalAddress) Mux.Trace)) dtHandshakeTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "Handshake", "Remote"] configureTracers configReflection trConfig [dtHandshakeTr] dtHandshakeTrDoc <- documentTracer (dtHandshakeTr :: - Trace IO (NtN.HandshakeTr NtN.RemoteAddress NtN.NodeToNodeVersion)) + Logging.Trace IO (NtN.HandshakeTr NtN.RemoteAddress NtN.NodeToNodeVersion)) dtLocalHandshakeTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "Handshake", "Local"] configureTracers configReflection trConfig [dtLocalHandshakeTr] dtLocalHandshakeTrDoc <- documentTracer (dtLocalHandshakeTr :: - Trace IO + Logging.Trace IO (NtC.HandshakeTr LocalAddress NtC.NodeToClientVersion)) dtDiffusionInitializationTr <- mkCardanoTracer @@ -513,14 +512,14 @@ docTracersFirstPhase condConfigFileName = do ["Startup", "DiffusionInit"] configureTracers configReflection trConfig [dtDiffusionInitializationTr] dtDiffusionInitializationTrDoc <- documentTracer (dtDiffusionInitializationTr :: - Trace IO (Diffusion.DiffusionTracer Socket.SockAddr LocalAddress)) + Logging.Trace IO (Diffusion.DiffusionTracer Socket.SockAddr LocalAddress)) dtLedgerPeersTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "Peers", "Ledger"] configureTracers configReflection trConfig [dtLedgerPeersTr] dtLedgerPeersTrDoc <- documentTracer (dtLedgerPeersTr :: - Trace IO TraceLedgerPeers) + Logging.Trace IO TraceLedgerPeers) -- DiffusionTracersExtra P2P localRootPeersTr <- mkCardanoTracer @@ -528,63 +527,63 @@ docTracersFirstPhase condConfigFileName = do ["Net", "Peers", "LocalRoot"] configureTracers configReflection trConfig [localRootPeersTr] localRootPeersTrDoc <- documentTracer (localRootPeersTr :: - Trace IO (TraceLocalRootPeers RemoteAddress SomeException)) + Logging.Trace IO (TraceLocalRootPeers RemoteAddress SomeException)) publicRootPeersTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "Peers", "PublicRoot"] configureTracers configReflection trConfig [publicRootPeersTr] publicRootPeersTrDoc <- documentTracer (publicRootPeersTr :: - Trace IO TracePublicRootPeers) + Logging.Trace IO TracePublicRootPeers) peerSelectionTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "PeerSelection", "Selection"] configureTracers configReflection trConfig [peerSelectionTr] peerSelectionTrDoc <- documentTracer (peerSelectionTr :: - Trace IO (TracePeerSelection Socket.SockAddr)) + Logging.Trace IO (TracePeerSelection Socket.SockAddr)) debugPeerSelectionTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "PeerSelection", "Initiator"] configureTracers configReflection trConfig [debugPeerSelectionTr] debugPeerSelectionTrDoc <- documentTracer (debugPeerSelectionTr :: - Trace IO (DebugPeerSelection Socket.SockAddr)) + Logging.Trace IO (DebugPeerSelection Socket.SockAddr)) debugPeerSelectionResponderTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "PeerSelection", "Responder"] configureTracers configReflection trConfig [debugPeerSelectionResponderTr] debugPeerSelectionResponderTrDoc <- documentTracer (debugPeerSelectionResponderTr :: - Trace IO (DebugPeerSelection Socket.SockAddr)) + Logging.Trace IO (DebugPeerSelection Socket.SockAddr)) peerSelectionCountersTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "PeerSelection", "Counters"] configureTracers configReflection trConfig [peerSelectionCountersTr] peerSelectionCountersTrDoc <- documentTracer (peerSelectionCountersTr :: - Trace IO PeerSelectionCounters) + Logging.Trace IO PeerSelectionCounters) churnCountersTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "Churn"] configureTracers configReflection trConfig [churnCountersTr] - churnCountersTrDoc <- documentTracer (churnCountersTr :: Trace IO ChurnCounters) + churnCountersTrDoc <- documentTracer (churnCountersTr :: Logging.Trace IO ChurnCounters) peerSelectionActionsTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "PeerSelection", "Actions"] configureTracers configReflection trConfig [peerSelectionActionsTr] peerSelectionActionsTrDoc <- documentTracer (peerSelectionActionsTr :: - Trace IO (PeerSelectionActionsTrace Socket.SockAddr LocalAddress)) + Logging.Trace IO (PeerSelectionActionsTrace Socket.SockAddr LocalAddress)) connectionManagerTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "ConnectionManager", "Remote"] configureTracers configReflection trConfig [connectionManagerTr] connectionManagerTrDoc <- documentTracer (connectionManagerTr :: - Trace IO - (ConnectionManagerTrace + Logging.Trace IO + (ConnectionManager.Trace Socket.SockAddr (ConnectionHandlerTrace UnversionedProtocol UnversionedProtocolData))) @@ -593,36 +592,36 @@ docTracersFirstPhase condConfigFileName = do ["Net", "ConnectionManager", "Transition"] configureTracers configReflection trConfig [connectionManagerTransitionsTr] connectionManagerTransitionsTrDoc <- documentTracer (connectionManagerTransitionsTr :: - Trace IO (ConnectionManager.AbstractTransitionTrace Socket.SockAddr)) + Logging.Trace IO (ConnectionManager.AbstractTransitionTrace Socket.SockAddr)) serverTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "Server", "Remote"] configureTracers configReflection trConfig [serverTr] serverTrDoc <- documentTracer (serverTr :: - Trace IO (ServerTrace Socket.SockAddr)) + Logging.Trace IO (Server.Trace Socket.SockAddr)) inboundGovernorTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "InboundGovernor", "Remote"] configureTracers configReflection trConfig [inboundGovernorTr] inboundGovernorTrDoc <- documentTracer (inboundGovernorTr :: - Trace IO (InboundGovernorTrace Socket.SockAddr)) + Logging.Trace IO (InboundGovernor.Trace Socket.SockAddr)) inboundGovernorTransitionsTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "InboundGovernor", "Transition"] configureTracers configReflection trConfig [inboundGovernorTransitionsTr] inboundGovernorTransitionsTrDoc <- documentTracer (inboundGovernorTransitionsTr :: - Trace IO (InboundGovernor.RemoteTransitionTrace Socket.SockAddr)) + Logging.Trace IO (InboundGovernor.RemoteTransitionTrace Socket.SockAddr)) localConnectionManagerTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "ConnectionManager", "Local"] configureTracers configReflection trConfig [localConnectionManagerTr] localConnectionManagerTrDoc <- documentTracer (localConnectionManagerTr :: - Trace IO - (ConnectionManagerTrace + Logging.Trace IO + (ConnectionManager.Trace Socket.SockAddr (ConnectionHandlerTrace UnversionedProtocol @@ -633,14 +632,14 @@ docTracersFirstPhase condConfigFileName = do ["Net", "Server", "Local"] configureTracers configReflection trConfig [localServerTr] localServerTrDoc <- documentTracer (localServerTr :: - Trace IO (ServerTrace LocalAddress)) + Logging.Trace IO (Server.Trace LocalAddress)) localInboundGovernorTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "InboundGovernor", "Local"] configureTracers configReflection trConfig [localInboundGovernorTr] localInboundGovernorTrDoc <- documentTracer (localInboundGovernorTr :: - Trace IO (InboundGovernorTrace LocalAddress)) + Logging.Trace IO (InboundGovernor.Trace LocalAddress)) -- -- DiffusionTracersExtra nonP2P @@ -650,49 +649,49 @@ docTracersFirstPhase condConfigFileName = do ["Net", "Subscription", "IP"] configureTracers configReflection trConfig [dtIpSubscriptionTr] dtIpSubscriptionTrDoc <- documentTracer (dtIpSubscriptionTr :: - Trace IO (WithIPList (SubscriptionTrace Socket.SockAddr))) + Logging.Trace IO (WithIPList (SubscriptionTrace Socket.SockAddr))) dtDnsSubscriptionTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "Subscription", "DNS"] configureTracers configReflection trConfig [dtDnsSubscriptionTr] dtDnsSubscriptionTrDoc <- documentTracer (dtDnsSubscriptionTr :: - Trace IO (WithDomainName (SubscriptionTrace Socket.SockAddr))) + Logging.Trace IO (WithDomainName (SubscriptionTrace Socket.SockAddr))) dtDnsResolverTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "DNSResolver"] configureTracers configReflection trConfig [dtDnsResolverTr] dtDnsResolverTrDoc <- documentTracer (dtDnsResolverTr :: - Trace IO (WithDomainName DnsTrace)) + Logging.Trace IO (WithDomainName DnsTrace)) dtErrorPolicyTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "ErrorPolicy", "Remote"] configureTracers configReflection trConfig [dtErrorPolicyTr] dtErrorPolicyTrDoc <- documentTracer (dtErrorPolicyTr :: - Trace IO (WithAddr Socket.SockAddr ErrorPolicyTrace)) + Logging.Trace IO (WithAddr Socket.SockAddr ErrorPolicyTrace)) dtLocalErrorPolicyTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "ErrorPolicy", "Local"] configureTracers configReflection trConfig [dtLocalErrorPolicyTr] dtLocalErrorPolicyTrDoc <- documentTracer (dtLocalErrorPolicyTr :: - Trace IO (WithAddr LocalAddress ErrorPolicyTrace)) + Logging.Trace IO (WithAddr LocalAddress ErrorPolicyTrace)) dtAcceptPolicyTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "AcceptPolicy"] configureTracers configReflection trConfig [dtAcceptPolicyTr] dtAcceptPolicyTrDoc <- documentTracer (dtAcceptPolicyTr :: - Trace IO NtN.AcceptConnectionsPolicyTrace) + Logging.Trace IO NtN.AcceptConnectionsPolicyTrace) internalTr <- mkCardanoTracer trBase trForward mbTrEKG ["Reflection"] configureTracers configReflection trConfig [internalTr] internalTrDoc <- documentTracer (internalTr :: - Trace IO TraceDispatcherMessage) + Logging.Trace IO TraceDispatcherMessage) let bl = nodeInfoDpDoc diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index b00ebe1c2d1..0fc00842fcd 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -18,6 +18,7 @@ module Cardano.Node.Tracing.Era.Shelley () where import Cardano.Api (textShow) +import Cardano.Api.Ledger (fromVRFVerKeyHash) import qualified Cardano.Api.Shelley as Api import qualified Cardano.Crypto.Hash.Class as Crypto @@ -131,10 +132,10 @@ instance LogFormatting (Conway.ConwayGovCertPredFailure era) where , "credential" .= String (textShow credential) , "error" .= String "DRep is not registered" ] - Conway.ConwayDRepIncorrectDeposit givenCoin expectedCoin -> + Conway.ConwayDRepIncorrectDeposit Mismatch {mismatchSupplied, mismatchExpected} -> [ "kind" .= String "ConwayDRepIncorrectDeposit" - , "givenCoin" .= givenCoin - , "expectedCoin" .= expectedCoin + , "givenCoin" .= mismatchSupplied + , "expectedCoin" .= mismatchExpected , "error" .= String "DRep delegation has incorrect deposit" ] Conway.ConwayCommitteeHasPreviouslyResigned coldCred -> @@ -147,10 +148,10 @@ instance LogFormatting (Conway.ConwayGovCertPredFailure era) where , "credential" .= String (textShow coldCred) , "error" .= String "Committee is Unknown" ] - Conway.ConwayDRepIncorrectRefund givenRefund expectedRefund -> + Conway.ConwayDRepIncorrectRefund Mismatch {mismatchSupplied, mismatchExpected} -> [ "kind" .= String "ConwayDRepIncorrectRefund" - , "givenRefund" .= givenRefund - , "expectedRefund" .= expectedRefund + , "givenRefund" .= mismatchSupplied + , "expectedRefund" .= mismatchExpected , "error" .= String "Refunds mismatch" ] @@ -360,10 +361,10 @@ instance , "received" .= map (Crypto.hashToTextAsHex . SafeHash.extractHash) (Set.toList received) ] - forMachine _ (PPViewHashesDontMatch ppHashInTxBody ppHashFromPParams) = + forMachine _ (PPViewHashesDontMatch Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "PPViewHashesDontMatch" - , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe ppHashInTxBody) - , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe ppHashFromPParams) + , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) + , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) ] forMachine _ (MissingRequiredSigners missingKeyWitnesses) = mconcat [ "kind" .= String "MissingRequiredSigners" @@ -448,10 +449,10 @@ instance , "badInputs" .= badInputs , "error" .= renderBadInputsUTxOErr badInputs ] - forMachine _dtal (ExpiredUTxO ttl slot) = + forMachine _dtal (ExpiredUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ExpiredUTxO" - , "ttl" .= ttl - , "slot" .= slot ] + , "ttl" .= mismatchSupplied + , "slot" .= mismatchExpected ] forMachine _dtal (MaxTxSizeUTxO (Mismatch { mismatchSupplied = txsize , mismatchExpected = maxtxsize })) = mconcat [ "kind" .= String "MaxTxSizeUTxO" @@ -481,11 +482,11 @@ instance mconcat [ "kind" .= String "FeeTooSmallUTxO" , "minimum" .= minfee , "fee" .= txfee ] - forMachine _dtal (ValueNotConservedUTxO consumed produced) = + forMachine _dtal (ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= consumed - , "produced" .= produced - , "error" .= renderValueNotConservedErr consumed produced + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected ] forMachine dtal (UpdateFailure f) = forMachine dtal f @@ -514,21 +515,21 @@ instance mconcat [ "kind" .= String "ExpiredUTxO" , "validityInterval" .= validityInterval , "slot" .= slot ] - forMachine _dtal (Allegra.MaxTxSizeUTxO txsize maxtxsize) = + forMachine _dtal (Allegra.MaxTxSizeUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= txsize - , "maxSize" .= maxtxsize ] + , "size" .= mismatchSupplied + , "maxSize" .= mismatchExpected ] forMachine _dtal Allegra.InputSetEmptyUTxO = mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - forMachine _dtal (Allegra.FeeTooSmallUTxO minfee txfee) = + forMachine _dtal (Allegra.FeeTooSmallUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= minfee - , "fee" .= txfee ] - forMachine _dtal (Allegra.ValueNotConservedUTxO consumed produced) = + , "minimum" .= mismatchExpected + , "fee" .= mismatchSupplied ] + forMachine _dtal (Allegra.ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= consumed - , "produced" .= produced - , "error" .= renderValueNotConservedErr consumed produced + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected ] forMachine _dtal (Allegra.WrongNetwork network addrs) = mconcat [ "kind" .= String "WrongNetwork" @@ -625,11 +626,6 @@ instance , "credential" .= String (textShow alreadyRegistered) , "error" .= String "Staking credential already registered" ] - forMachine _dtal (StakeKeyInRewardsDELEG alreadyRegistered) = - mconcat [ "kind" .= String "StakeKeyInRewardsDELEG" - , "credential" .= String (textShow alreadyRegistered) - , "error" .= String "Staking credential registered in rewards map" - ] forMachine _dtal (StakeKeyNotRegisteredDELEG notRegistered) = mconcat [ "kind" .= String "StakeKeyNotRegisteredDELEG" , "credential" .= String (textShow notRegistered) @@ -656,22 +652,22 @@ instance , "duplicateKeyHash" .= String (textShow genesisKeyHash) , "error" .= String "This genesis key has already been delegated to" ] - forMachine _dtal (InsufficientForInstantaneousRewardsDELEG mirpot neededMirAmount reserves) = + forMachine _dtal (InsufficientForInstantaneousRewardsDELEG mirpot Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "InsufficientForInstantaneousRewardsDELEG" , "pot" .= String (case mirpot of ReservesMIR -> "Reserves" TreasuryMIR -> "Treasury") - , "neededAmount" .= neededMirAmount - , "reserves" .= reserves + , "neededAmount" .= mismatchSupplied + , "reserves" .= mismatchExpected ] - forMachine _dtal (MIRCertificateTooLateinEpochDELEG currSlot boundSlotNo) = + forMachine _dtal (MIRCertificateTooLateinEpochDELEG Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "MIRCertificateTooLateinEpochDELEG" - , "currentSlotNo" .= currSlot - , "mustBeSubmittedBeforeSlotNo" .= boundSlotNo + , "currentSlotNo" .= mismatchSupplied + , "mustBeSubmittedBeforeSlotNo" .= mismatchExpected ] forMachine _dtal (DuplicateGenesisVRFDELEG vrfKeyHash) = mconcat [ "kind" .= String "DuplicateGenesisVRFDELEG" - , "keyHash" .= vrfKeyHash + , "keyHash" .= fromVRFVerKeyHash vrfKeyHash ] forMachine _dtal MIRTransferNotCurrentlyAllowed = mconcat [ "kind" .= String "MIRTransferNotCurrentlyAllowed" @@ -679,13 +675,13 @@ instance forMachine _dtal MIRNegativesNotCurrentlyAllowed = mconcat [ "kind" .= String "MIRNegativesNotCurrentlyAllowed" ] - forMachine _dtal (InsufficientForTransferDELEG mirpot attempted available) = + forMachine _dtal (InsufficientForTransferDELEG mirpot Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "DuplicateGenesisVRFDELEG" , "pot" .= String (case mirpot of ReservesMIR -> "Reserves" TreasuryMIR -> "Treasury") - , "attempted" .= attempted - , "available" .= available + , "attempted" .= mismatchSupplied + , "available" .= mismatchExpected ] forMachine _dtal MIRProducesNegativeUpdate = mconcat [ "kind" .= String "MIRProducesNegativeUpdate" @@ -919,23 +915,23 @@ instance , "validityInterval" .= validtyInterval , "slot" .= slot ] - forMachine _dtal (Alonzo.MaxTxSizeUTxO txsize maxtxsize) = + forMachine _dtal (Alonzo.MaxTxSizeUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= txsize - , "maxSize" .= maxtxsize + , "size" .= mismatchSupplied + , "maxSize" .= mismatchExpected ] forMachine _dtal Alonzo.InputSetEmptyUTxO = mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - forMachine _dtal (Alonzo.FeeTooSmallUTxO minfee currentFee) = + forMachine _dtal (Alonzo.FeeTooSmallUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= minfee - , "fee" .= currentFee + , "minimum" .= mismatchExpected + , "fee" .= mismatchSupplied ] - forMachine _dtal (Alonzo.ValueNotConservedUTxO consumed produced) = + forMachine _dtal (Alonzo.ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= consumed - , "produced" .= produced - , "error" .= renderValueNotConservedErr consumed produced + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected ] forMachine _dtal (Alonzo.WrongNetwork network addrs) = mconcat [ "kind" .= String "WrongNetwork" @@ -980,28 +976,28 @@ instance mconcat [ "kind" .= String "ScriptsNotPaidUTxO" , "utxos" .= utxos ] - forMachine _dtal (Alonzo.ExUnitsTooBigUTxO pParamsMaxExUnits suppliedExUnits) = + forMachine _dtal (Alonzo.ExUnitsTooBigUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ExUnitsTooBigUTxO" - , "maxexunits" .= pParamsMaxExUnits - , "exunits" .= suppliedExUnits + , "maxexunits" .= mismatchExpected + , "exunits" .= mismatchSupplied ] forMachine _dtal (Alonzo.CollateralContainsNonADA inputs) = mconcat [ "kind" .= String "CollateralContainsNonADA" , "inputs" .= inputs ] - forMachine _dtal (Alonzo.WrongNetworkInTxBody actualNetworkId netIdInTxBody) = + forMachine _dtal (Alonzo.WrongNetworkInTxBody Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "WrongNetworkInTxBody" - , "networkid" .= actualNetworkId - , "txbodyNetworkId" .= netIdInTxBody + , "networkid" .= mismatchExpected + , "txbodyNetworkId" .= mismatchSupplied ] forMachine _dtal (Alonzo.OutsideForecast slotNum) = mconcat [ "kind" .= String "OutsideForecast" , "slot" .= slotNum ] - forMachine _dtal (Alonzo.TooManyCollateralInputs maxCollateralInputs numberCollateralInputs) = + forMachine _dtal (Alonzo.TooManyCollateralInputs Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "TooManyCollateralInputs" - , "max" .= maxCollateralInputs - , "inputs" .= numberCollateralInputs + , "max" .= mismatchExpected + , "inputs" .= mismatchSupplied ] forMachine _dtal Alonzo.NoCollateralInputs = mconcat [ "kind" .= String "NoCollateralInputs" ] @@ -1106,18 +1102,18 @@ instance , LogFormatting (NonEmpty.NonEmpty (KeyHash 'Staking (Ledger.EraCrypto era))) ) => LogFormatting (Conway.ConwayLedgerPredFailure era) where forMachine v (Conway.ConwayUtxowFailure f) = forMachine v f - forMachine _ (Conway.ConwayTxRefScriptsSizeTooBig actual limit) = + forMachine _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" - , "actual" .= actual - , "limit" .= limit + , "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 actual inTx) = + forMachine _ (Conway.ConwayTreasuryValueMismatch Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTreasuryValueMismatch" - , "actual" .= actual - , "submittedInTx" .= inTx + , "actual" .= mismatchExpected + , "submittedInTx" .= mismatchSupplied ] forMachine _ (Conway.ConwayMempoolFailure message) = mconcat [ "kind" .= String "ConwayMempoolFailure" @@ -1145,10 +1141,10 @@ instance , "rewardAccounts" .= toJSON rewardAcnts , "expectedNetworkId" .= toJSON network ] - forMachine _ (Conway.ProposalDepositIncorrect deposit expectedDeposit) = + forMachine _ (Conway.ProposalDepositIncorrect Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ProposalDepositIncorrect" - , "deposit" .= deposit - , "expectedDeposit" .= expectedDeposit + , "deposit" .= mismatchSupplied + , "expectedDeposit" .= mismatchExpected ] forMachine _ (Conway.DisallowedVoters govActionIdToVoter) = mconcat [ "kind" .= String "DisallowedVoters" @@ -1174,11 +1170,11 @@ instance mconcat [ "kind" .= String "VotingOnExpiredGovAction" , "action" .= actions ] - forMachine _ (Conway.ProposalCantFollow prevGovActionId protVer prevProtVer) = + forMachine _ (Conway.ProposalCantFollow prevGovActionId Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ProposalCantFollow" , "prevGovActionId" .= prevGovActionId - , "protVer" .= protVer - , "prevProtVer" .= prevProtVer + , "protVer" .= mismatchSupplied + , "prevProtVer" .= mismatchExpected ] forMachine _ (Conway.InvalidPolicyHash actualPolicyHash expectedPolicyHash) = mconcat [ "kind" .= String "InvalidPolicyHash" @@ -1272,11 +1268,12 @@ instance , "opCertStartingKesPeriod" .= oCertStartKesPeriod , "error" .= err ] - Praos.InvalidKesSignatureOCERT currentKesPeriod opCertStartKesPeriod expectedKesEvos 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-> @@ -1366,23 +1363,23 @@ instance , "validityInterval" .= validityInterval , "slot" .= slot ] - Conway.MaxTxSizeUTxO txsize maxtxsize -> + Conway.MaxTxSizeUTxO Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= txsize - , "maxSize" .= maxtxsize + , "size" .= mismatchSupplied + , "maxSize" .= mismatchExpected ] Conway.InputSetEmptyUTxO -> mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - Conway.FeeTooSmallUTxO minfee txfee -> + Conway.FeeTooSmallUTxO Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= minfee - , "fee" .= txfee + , "minimum" .= mismatchExpected + , "fee" .= mismatchSupplied ] - Conway.ValueNotConservedUTxO consumed produced -> + Conway.ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= consumed - , "produced" .= produced - , "error" .= renderValueNotConservedErr consumed produced + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected ] Conway.WrongNetwork network addrs -> mconcat [ "kind" .= String "WrongNetwork" @@ -1423,28 +1420,28 @@ instance mconcat [ "kind" .= String "ScriptsNotPaidUTxO" , "utxos" .= utxos ] - Conway.ExUnitsTooBigUTxO pParamsMaxExUnits suppliedExUnits -> + Conway.ExUnitsTooBigUTxO Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "ExUnitsTooBigUTxO" - , "maxexunits" .= pParamsMaxExUnits - , "exunits" .= suppliedExUnits + , "maxexunits" .= mismatchExpected + , "exunits" .= mismatchSupplied ] Conway.CollateralContainsNonADA inputs -> mconcat [ "kind" .= String "CollateralContainsNonADA" , "inputs" .= inputs ] - Conway.WrongNetworkInTxBody actualNetworkId netIdInTxBody -> + Conway.WrongNetworkInTxBody Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "WrongNetworkInTxBody" - , "networkid" .= actualNetworkId - , "txbodyNetworkId" .= netIdInTxBody + , "networkid" .= mismatchExpected + , "txbodyNetworkId" .= mismatchSupplied ] Conway.OutsideForecast slotNum -> mconcat [ "kind" .= String "OutsideForecast" , "slot" .= slotNum ] - Conway.TooManyCollateralInputs maxCollateralInputs numberCollateralInputs -> + Conway.TooManyCollateralInputs Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "TooManyCollateralInputs" - , "max" .= maxCollateralInputs - , "inputs" .= numberCollateralInputs + , "max" .= mismatchExpected + , "inputs" .= mismatchSupplied ] Conway.NoCollateralInputs -> mconcat [ "kind" .= String "NoCollateralInputs" ] @@ -1495,10 +1492,10 @@ instance mconcat [ "kind" .= String "MissingTxMetadata" , "txBodyMetadataHash" .= hash ] - Conway.ConflictingMetadataHash txBodyMetadataHash fullMetadataHash -> + Conway.ConflictingMetadataHash Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "ConflictingMetadataHash" - , "txBodyMetadataHash" .= txBodyMetadataHash - , "fullMetadataHash" .= fullMetadataHash + , "txBodyMetadataHash" .= mismatchSupplied + , "fullMetadataHash" .= mismatchExpected ] Conway.InvalidMetadata -> mconcat [ "kind" .= String "InvalidMetadata" @@ -1523,10 +1520,10 @@ instance , "disallowed" .= Set.toList disallowed , "acceptable" .= Set.toList acceptable ] - Conway.PPViewHashesDontMatch ppHashInTxBody ppHashFromPParams -> + Conway.PPViewHashesDontMatch Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "PPViewHashesDontMatch" - , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe ppHashInTxBody) - , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe ppHashFromPParams) + , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) + , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) ] Conway.UnspendableUTxONoDatumHash ins -> mconcat [ "kind" .= String "MissingRequiredSigners" diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index 4fab3056553..171b7daaf3c 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -335,6 +335,11 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf ["Consensus", "GSM"] configureTracers configReflection trConfig [consensusGsmTr] + !consensusCsjTr <- mkCardanoTracer + trBase trForward mbTrEKG + ["Consensus", "CSJ"] + configureTracers configReflection trConfig [consensusCsjTr] + pure $ Consensus.Tracers { Consensus.chainSyncClientTracer = Tracer $ traceWith chainSyncClientTr @@ -377,6 +382,8 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf traceWith consensusStartupErrorTr . ConsensusStartupException , Consensus.gsmTracer = Tracer $ traceWith consensusGsmTr + , Consensus.csjTracer = Tracer $ + traceWith consensusCsjTr } mkNodeToClientTracers :: forall blk. @@ -461,6 +468,11 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon ["TxSubmission", "Remote"] configureTracers configReflection trConfig [txSubmission2Tracer] + !keepAliveTracer <- mkCardanoTracer + trBase trForward mbTrEKG + ["KeepAlive", "Remote"] + configureTracers configReflection trConfig [keepAliveTracer] + pure $ NtN.Tracers { NtN.tChainSyncTracer = Tracer $ traceWith chainSyncTracer @@ -472,6 +484,8 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon traceWith blockFetchSerialisedTr , NtN.tTxSubmission2Tracer = Tracer $ traceWith txSubmission2Tracer + , NtN.tKeepAliveTracer = Tracer $ + traceWith keepAliveTracer } mkDiffusionTracers diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index adabc99b0d6..4392d1527b4 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -93,9 +93,20 @@ instance ( LogFormatting (Header blk) forHuman (ChainDB.TraceLedgerReplayEvent v) = forHumanOrMachine v forHuman (ChainDB.TraceImmutableDBEvent v) = forHumanOrMachine v forHuman (ChainDB.TraceVolatileDBEvent v) = forHumanOrMachine 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 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.TraceAddBlockEvent v) = forMachine details v forMachine details (ChainDB.TraceFollowerEvent v) = @@ -119,23 +130,26 @@ instance ( LogFormatting (Header blk) forMachine details (ChainDB.TraceVolatileDBEvent v) = forMachine details v - asMetrics ChainDB.TraceLastShutdownUnclean = [] - 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.TraceSnapshotEvent v) = asMetrics v - asMetrics (ChainDB.TraceLedgerReplayEvent v) = asMetrics v - asMetrics (ChainDB.TraceImmutableDBEvent v) = asMetrics v - asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v + asMetrics ChainDB.TraceLastShutdownUnclean = [] + asMetrics (ChainDB.TraceChainSelStarvationEvent _) = [] + 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.TraceSnapshotEvent v) = asMetrics v + asMetrics (ChainDB.TraceLedgerReplayEvent v) = asMetrics v + asMetrics (ChainDB.TraceImmutableDBEvent v) = asMetrics v + asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v instance MetaTrace (ChainDB.TraceEvent blk) where namespaceFor ChainDB.TraceLastShutdownUnclean = Namespace [] ["LastShutdownUnclean"] + namespaceFor ChainDB.TraceChainSelStarvationEvent{} = + Namespace [] ["ChainSelStarvationEvent"] namespaceFor (ChainDB.TraceAddBlockEvent ev) = nsPrependInner "AddBlockEvent" (namespaceFor ev) namespaceFor (ChainDB.TraceFollowerEvent ev) = @@ -160,6 +174,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where nsPrependInner "VolatileDbEvent" (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 = @@ -207,6 +222,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where 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 = @@ -254,6 +270,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where 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 = @@ -329,6 +346,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where , " 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)) = @@ -355,7 +376,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where allNamespaces = Namespace [] ["LastShutdownUnclean"] - + : Namespace [] ["ChainSelStarvationEvent"] : (map (nsPrependInner "AddBlockEvent") (allNamespaces :: [Namespace (ChainDB.TraceAddBlockEvent blk)]) ++ map (nsPrependInner "FollowerEvent") @@ -413,8 +434,6 @@ instance ( LogFormatting (Header blk) "Popping block from queue" FallingEdgeWith pt -> "Popped block from queue: " <> renderRealPointAsPhrase pt - forHuman (ChainDB.BlockInTheFuture pt slot) = - "Ignoring block from future: " <> renderRealPointAsPhrase pt <> ", slot " <> condenseT slot forHuman (ChainDB.StoreButDontChange pt) = "Ignoring block: " <> renderRealPointAsPhrase pt forHuman (ChainDB.TryAddToCurrentChain pt) = @@ -434,8 +453,6 @@ instance ( LogFormatting (Header blk) case enclosing of RisingEdge -> "Chain about to add block " <> renderRealPointAsPhrase pt FallingEdge -> "Chain added block " <> renderRealPointAsPhrase pt - forHuman (ChainDB.ChainSelectionForFutureBlock pt) = - "Chain selection run for block previously from future: " <> renderRealPointAsPhrase pt forHuman (ChainDB.PipeliningEvent ev') = forHumanOrMachine ev' forHuman ChainDB.AddedReprocessLoEBlocksToQueue = "Added request to queue to reprocess blocks postponed by LoE." @@ -464,10 +481,6 @@ instance ( LogFormatting (Header blk) , case edgePt of RisingEdge -> "risingEdge" .= True FallingEdgeWith pt -> "block" .= forMachine dtal pt ] - forMachine dtal (ChainDB.BlockInTheFuture pt slot) = - mconcat [ "kind" .= String "BlockInTheFuture" - , "block" .= forMachine dtal pt - , "slot" .= forMachine dtal slot ] forMachine dtal (ChainDB.StoreButDontChange pt) = mconcat [ "kind" .= String "StoreButDontChange" , "block" .= forMachine dtal pt ] @@ -513,9 +526,6 @@ instance ( LogFormatting (Header blk) , "block" .= forMachine dtal pt , "blockNo" .= showT bn ] <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ] - forMachine dtal (ChainDB.ChainSelectionForFutureBlock pt) = - mconcat [ "kind" .= String "TChainSelectionForFutureBlock" - , "block" .= forMachine dtal pt ] forMachine dtal (ChainDB.PipeliningEvent ev') = forMachine dtal ev' forMachine _dtal ChainDB.AddedReprocessLoEBlocksToQueue = @@ -575,8 +585,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where Namespace [] ["AddedBlockToQueue"] namespaceFor ChainDB.PoppedBlockFromQueue {} = Namespace [] ["PoppedBlockFromQueue"] - namespaceFor ChainDB.BlockInTheFuture {} = - Namespace [] ["BlockInTheFuture"] namespaceFor ChainDB.AddedBlockToVolatileDB {} = Namespace [] ["AddedBlockToVolatileDB"] namespaceFor ChainDB.TryAddToCurrentChain {} = @@ -593,8 +601,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where Namespace [] ["ChangingSelection"] namespaceFor (ChainDB.AddBlockValidation ev') = nsPrependInner "AddBlockValidation" (namespaceFor ev') - namespaceFor ChainDB.ChainSelectionForFutureBlock {} = - Namespace [] ["ChainSelectionForFutureBlock"] namespaceFor (ChainDB.PipeliningEvent ev') = nsPrependInner "PipeliningEvent" (namespaceFor ev') namespaceFor ChainDB.AddedReprocessLoEBlocksToQueue = @@ -608,7 +614,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where severityFor (Namespace _ ["IgnoreBlockAlreadyInVolatileDB"]) _ = Just Info severityFor (Namespace _ ["IgnoreInvalidBlock"]) _ = Just Info severityFor (Namespace _ ["AddedBlockToQueue"]) _ = Just Debug - severityFor (Namespace _ ["BlockInTheFuture"]) _ = Just Info severityFor (Namespace _ ["AddedBlockToVolatileDB"]) _ = Just Debug severityFor (Namespace _ ["PoppedBlockFromQueue"]) _ = Just Debug severityFor (Namespace _ ["TryAddToCurrentChain"]) _ = Just Debug @@ -628,7 +633,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where (Just (ChainDB.AddBlockValidation ev')) = severityFor (Namespace out tl) (Just ev') severityFor (Namespace _ ("AddBlockValidation" : _tl)) Nothing = Just Notice - severityFor (Namespace _ ["ChainSelectionForFutureBlock"]) _ = Just Debug severityFor (Namespace out ("PipeliningEvent" : tl)) (Just (ChainDB.PipeliningEvent ev')) = severityFor (Namespace out tl) (Just ev') severityFor (Namespace out ("PipeliningEvent" : tl)) Nothing = @@ -718,10 +722,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where [ "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 _ ["BlockInTheFuture"]) = Just $ mconcat - [ "The block is from the future, i.e., its slot number is greater than" - , " the current slot (the second argument)." - ] documentFor (Namespace _ ["AddedBlockToVolatileDB"]) = Just "A block was added to the Volatile DB" documentFor (Namespace _ ["PoppedBlockFromQueue"]) = Just "" @@ -754,11 +754,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where ] documentFor (Namespace out ("AddBlockValidation" : tl)) = documentFor (Namespace out tl :: Namespace (ChainDB.TraceValidationEvent blk)) - documentFor (Namespace _ ["ChainSelectionForFutureBlock"]) = Just $ mconcat - [ "Run chain selection for a block that was previously from the future." - , " This is done for all blocks from the future each time a new block is" - , " added." - ] documentFor (Namespace out ("PipeliningEvent" : tl)) = documentFor (Namespace out tl :: Namespace (ChainDB.TracePipeliningEvent blk)) documentFor _ = Nothing @@ -769,7 +764,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where , Namespace [] ["IgnoreBlockAlreadyInVolatileDB"] , Namespace [] ["IgnoreInvalidBlock"] , Namespace [] ["AddedBlockToQueue"] - , Namespace [] ["BlockInTheFuture"] , Namespace [] ["AddedBlockToVolatileDB"] , Namespace [] ["PoppedBlockFromQueue"] , Namespace [] ["TryAddToCurrentChain"] @@ -778,7 +772,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where , Namespace [] ["ChangingSelection"] , Namespace [] ["AddedToCurrentChain"] , Namespace [] ["SwitchedToAFork"] - , Namespace [] ["ChainSelectionForFutureBlock"] , Namespace [] ["AddedReprocessLoEBlocksToQueue"] , Namespace [] ["PoppedReprocessLoEBlocksFromQueue"] , Namespace [] ["ChainSelectionLoEDebug"] @@ -1096,14 +1089,6 @@ instance ( LedgerSupportsProtocol blk "Invalid block " <> renderRealPointAsPhrase pt <> ": " <> showT err forHuman (ChainDB.ValidCandidate c) = "Valid candidate " <> renderPointAsPhrase (AF.headPoint c) - forHuman (ChainDB.CandidateContainsFutureBlocks c hdrs) = - "Candidate contains blocks from near future: " <> - renderPointAsPhrase (AF.headPoint c) <> ", slots " <> - Text.intercalate ", " (map (renderPoint . headerPoint) hdrs) - forHuman (ChainDB.CandidateContainsFutureBlocksExceedingClockSkew c hdrs) = - "Candidate contains blocks from future exceeding clock skew limit: " <> - renderPointAsPhrase (AF.headPoint c) <> ", slots " <> - Text.intercalate ", " (map (renderPoint . headerPoint) hdrs) forHuman (ChainDB.UpdateLedgerDbTraceEvent (StartedPushingBlockToTheLedgerDb (LedgerDB.PushStart start) @@ -1125,14 +1110,6 @@ instance ( LedgerSupportsProtocol blk forMachine dtal (ChainDB.ValidCandidate c) = mconcat [ "kind" .= String "ValidCandidate" , "block" .= renderPointForDetails dtal (AF.headPoint c) ] - forMachine dtal (ChainDB.CandidateContainsFutureBlocks c hdrs) = - mconcat [ "kind" .= String "CandidateContainsFutureBlocks" - , "block" .= renderPointForDetails dtal (AF.headPoint c) - , "headers" .= map (renderPointForDetails dtal . headerPoint) hdrs ] - forMachine dtal (ChainDB.CandidateContainsFutureBlocksExceedingClockSkew c hdrs) = - mconcat [ "kind" .= String "CandidateContainsFutureBlocksExceedingClockSkew" - , "block" .= renderPointForDetails dtal (AF.headPoint c) - , "headers" .= map (renderPointForDetails dtal . headerPoint) hdrs ] forMachine _dtal (ChainDB.UpdateLedgerDbTraceEvent (StartedPushingBlockToTheLedgerDb (LedgerDB.PushStart start) @@ -1147,18 +1124,12 @@ instance ( LedgerSupportsProtocol blk instance MetaTrace (ChainDB.TraceValidationEvent blk) where namespaceFor ChainDB.ValidCandidate {} = Namespace [] ["ValidCandidate"] - namespaceFor ChainDB.CandidateContainsFutureBlocks {} = - Namespace [] ["CandidateContainsFutureBlocks"] - namespaceFor ChainDB.CandidateContainsFutureBlocksExceedingClockSkew {} = - Namespace [] ["CandidateContainsFutureBlocksExceedingClockSkew"] namespaceFor ChainDB.InvalidBlock {} = Namespace [] ["InvalidBlock"] namespaceFor ChainDB.UpdateLedgerDbTraceEvent {} = Namespace [] ["UpdateLedgerDb"] severityFor (Namespace _ ["ValidCandidate"]) _ = Just Info - severityFor (Namespace _ ["CandidateContainsFutureBlocks"]) _ = Just Debug - severityFor (Namespace _ ["CandidateContainsFutureBlocksExceedingClockSkew"]) _ = Just Error severityFor (Namespace _ ["InvalidBlock"]) _ = Just Error severityFor (Namespace _ ["UpdateLedgerDb"]) _ = Just Debug severityFor _ _ = Nothing @@ -1167,16 +1138,6 @@ instance MetaTrace (ChainDB.TraceValidationEvent blk) where [ "An event traced during validating performed while adding a block." , " A candidate chain was valid." ] - documentFor (Namespace _ ["CandidateContainsFutureBlocks"]) = Just $ mconcat - [ "An event traced during validating performed while adding a block." - , " Candidate contains headers from the future which do no exceed the" - , " clock skew." - ] - documentFor (Namespace _ ["CandidateContainsFutureBlocksExceedingClockSkew"]) = Just $ mconcat - [ "An event traced during validating performed while adding a block." - , " Candidate contains headers from the future which exceed the" - , " clock skew." - ] documentFor (Namespace _ ["InvalidBlock"]) = Just $ mconcat [ "An event traced during validating performed while adding a block." , " A point was found to be invalid." @@ -1186,8 +1147,6 @@ instance MetaTrace (ChainDB.TraceValidationEvent blk) where allNamespaces = [ Namespace [] ["ValidCandidate"] - , Namespace [] ["CandidateContainsFutureBlocks"] - , Namespace [] ["CandidateContainsFutureBlocksExceedingClockSkew"] , Namespace [] ["InvalidBlock"] , Namespace [] ["UpdateLedgerDb"] ] @@ -1510,21 +1469,35 @@ instance ( StandardHash blk , ConvertRawHash blk) => LogFormatting (LedgerDB.TraceSnapshotEvent blk) where forHuman (LedgerDB.TookSnapshot snap pt RisingEdge) = - "Taking ledger snapshot " <> showT snap <> - " at " <> renderRealPointAsPhrase pt + Text.unwords [ "Taking ledger snapshot" + , showT snap + , "at" + , renderRealPointAsPhrase pt + ] forHuman (LedgerDB.TookSnapshot snap pt (FallingEdgeWith t)) = - "Took ledger snapshot " <> showT snap <> - " at " <> renderRealPointAsPhrase pt <> ", duration: " <> showT t + Text.unwords [ "Took ledger snapshot" + , showT snap + , "at" + , renderRealPointAsPhrase pt + , ", duration:" + , showT t + ] forHuman (LedgerDB.DeletedSnapshot snap) = - "Deleted old snapshot " <> showT snap + Text.unwords ["Deleted old snapshot", showT snap] forHuman (LedgerDB.InvalidSnapshot snap failure) = - "Invalid snapshot " <> showT snap <> showT failure <> context + Text.unwords [ "Invalid snapshot" + , showT snap + , showT failure + , context + ] where context = case failure of LedgerDB.InitFailureRead{} -> " This is most likely an expected change in the serialization format," <> " which currently requires a chain replay" _ -> "" + forHuman (LedgerDB.SnapshotMissingChecksum snap) = + "Checksum file is missing for snapshot " <> showT snap forMachine dtals (LedgerDB.TookSnapshot snap pt enclosedTiming) = mconcat [ "kind" .= String "TookSnapshot" @@ -1538,15 +1511,21 @@ instance ( StandardHash blk mconcat [ "kind" .= String "InvalidSnapshot" , "snapshot" .= forMachine dtals snap , "failure" .= show failure ] + forMachine dtals (LedgerDB.SnapshotMissingChecksum snap) = + mconcat [ "kind" .= String "SnapshotMissingChecksum" + , "snapshot" .= forMachine dtals snap + ] instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where namespaceFor LedgerDB.TookSnapshot {} = Namespace [] ["TookSnapshot"] namespaceFor LedgerDB.DeletedSnapshot {} = Namespace [] ["DeletedSnapshot"] namespaceFor LedgerDB.InvalidSnapshot {} = Namespace [] ["InvalidSnapshot"] + namespaceFor LedgerDB.SnapshotMissingChecksum {} = Namespace [] ["SnapshotMissingChecksum"] severityFor (Namespace _ ["TookSnapshot"]) _ = Just Info severityFor (Namespace _ ["DeletedSnapshot"]) _ = Just Debug severityFor (Namespace _ ["InvalidSnapshot"]) _ = Just Error + severityFor (Namespace _ ["SnapshotMissingChecksum"]) _ = Just Warning severityFor _ _ = Nothing documentFor (Namespace _ ["TookSnapshot"]) = Just $ mconcat @@ -1558,12 +1537,15 @@ instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where "A snapshot was deleted from the disk." documentFor (Namespace _ ["InvalidSnapshot"]) = Just "An on disk snapshot was invalid. Unless it was suffixed, it will be deleted" + documentFor (Namespace _ ["SnapshotMissingChecksum"]) = Just + "Checksum file was missing for snapshot." documentFor _ = Nothing allNamespaces = [ Namespace [] ["TookSnapshot"] , Namespace [] ["DeletedSnapshot"] , Namespace [] ["InvalidSnapshot"] + , Namespace [] ["SnapshotMissingChecksum"] ] @@ -2248,23 +2230,3 @@ instance (Show (PBFT.PBftVerKeyHash c)) [ "kind" .= String "PBftCannotForgeThresholdExceeded" , "numForged" .= numForged ] - -instance ( ConvertRawHash blk - , StandardHash blk - , LogFormatting (LedgerError blk) - , LogFormatting (RealPoint blk) - , LogFormatting (OtherHeaderEnvelopeError blk) - , LogFormatting (ExtValidationError blk) - , LogFormatting (ValidationErr (BlockProtocol blk)) - ) - => LogFormatting (ChainDB.InvalidBlockReason blk) where - forMachine dtal (ChainDB.ValidationError extvalerr) = - mconcat - [ "kind" .= String "ValidationError" - , "error" .= forMachine dtal extvalerr - ] - forMachine dtal (ChainDB.InFutureExceedsClockSkew point) = - mconcat - [ "kind" .= String "InFutureExceedsClockSkew" - , "point" .= forMachine dtal point - ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 38d8b141c6d..e40a453120b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -32,6 +32,7 @@ import Cardano.Node.Tracing.Formatting () import Cardano.Node.Tracing.Render import Cardano.Node.Tracing.Tracers.ConsensusStartupException () import Cardano.Node.Tracing.Tracers.StartLeadershipCheck +import Cardano.Tracing.OrphanInstances.Network (Verbose (..)) import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) import Cardano.Slotting.Slot (WithOrigin (..)) import Ouroboros.Consensus.Block @@ -40,6 +41,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockch 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, txForgetValidated, txId) @@ -48,8 +50,7 @@ import Ouroboros.Consensus.Mempool (MempoolSize (..), TraceEventMempoo import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server (TraceBlockFetchServerEvent (..)) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client -import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping (Instruction (..), - JumpInstruction (..), JumpResult (..)) +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 @@ -65,12 +66,14 @@ 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.ConnectionId (ConnectionId (..)) import Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..)) import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) import Ouroboros.Network.TxSubmission.Inbound hiding (txId) import Ouroboros.Network.TxSubmission.Outbound +import Network.TypedProtocol.Core import Control.Monad (guard) import Control.Monad.Class.MonadTime.SI (Time (..)) @@ -230,6 +233,8 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk) [ "ChainSync Jumping -- the client is asked to jump to " , showT (jumpInstructionToPoint instruction) ] + TraceDrainingThePipe n -> + "ChainSync client is draining the pipe. Pipelined messages expected: " <> showT (natToInt n) where jumpInstructionToPoint = AF.headPoint . jTheirFragment . \case JumpTo ji -> ji @@ -303,6 +308,11 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk) [ "kind" .= String "TraceJumpingInstructionIs" , "instr" .= instructionToObject instruction ] + TraceDrainingThePipe n -> + mconcat + [ "kind" .= String "TraceDrainingThePipe" + , "n" .= natToInt n + ] where instructionToObject :: Instruction blk -> Aeson.Object instructionToObject = \case @@ -326,6 +336,30 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk) jumpInfoToPoint = AF.headPoint . jTheirFragment +-- TODO @tweag-genesis +instance MetaTrace (Jumping.TraceEvent addr) where + namespaceFor RotatedDynamo{} = Namespace [] ["RotatedDynamo"] + + severityFor (Namespace [] ["RotatedDynamo"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace [] ["RotatedDynamo"]) = + Just "The dynamo rotated" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["RotatedDynamo"] ] + +instance Show addr => LogFormatting (Jumping.TraceEvent addr) where + forHuman (RotatedDynamo fromPeer toPeer) = + "Rotated the dynamo from " <> showT fromPeer <> " to " <> showT toPeer + forMachine _dtal (RotatedDynamo fromPeer toPeer) = + mconcat + [ "kind" .= String "RotatedDynamo" + , "from" .= showT fromPeer + , "to" .= showT toPeer + ] + tipToObject :: forall blk. ConvertRawHash blk => Tip blk -> Aeson.Object tipToObject = \case TipGenesis -> mconcat @@ -367,6 +401,8 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where Namespace [] ["JumpingWaitingForNextInstruction"] TraceJumpingInstructionIs _ -> Namespace [] ["JumpingInstructionIs"] + TraceDrainingThePipe _ -> + Namespace [] ["DrainingThePipe"] severityFor ns _ = case ns of @@ -396,6 +432,8 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where Just Debug Namespace _ ["JumpingInstructionIs"] -> Just Debug + Namespace _ ["DrainingThePipe"] -> + Just Debug _ -> Nothing @@ -433,6 +471,8 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where 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 @@ -450,6 +490,7 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where , Namespace [] ["JumpResult"] , Namespace [] ["JumpingWaitingForNextInstruction"] , Namespace [] ["JumpingInstructionIs"] + , Namespace [] ["DrainingThePipe"] ] -------------------------------------------------------------------------------- @@ -659,6 +700,38 @@ calculateBlockFetchClientMetrics cm _lc _ = pure 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, ConvertRawHash (Header blk), HasHeader blk) + => LogFormatting (TraceDecisionEvent peer (Header blk)) where + forHuman = Text.pack . show + + forMachine dtal (PeersFetch xs) = + mconcat [ "kind" .= String "PeerFetch" + , "decisions" .= if dtal >= DMaximum + then toJSON (Verbose <$> xs) + else toJSON xs + ] + forMachine _dtal (PeerStarvedUs peer) = + mconcat [ "kind" .= String "PeerStarvedUs" + , "peer" .= toJSON peer + ] + instance (LogFormatting peer, Show peer) => LogFormatting [TraceLabelPeer peer (FetchDecision [Point header])] where forMachine DMinimal _ = mempty @@ -1374,8 +1447,8 @@ instance ( tx ~ GenTx blk , HasTxId (GenTx blk) , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) - , LogFormatting (InvalidBlockReason blk) , LogFormatting (CannotForge blk) + , LogFormatting (ExtValidationError blk) , LogFormatting (ForgeStateUpdateError blk)) => LogFormatting (ForgeTracerType blk) where forMachine dtal (Left i) = forMachine dtal i @@ -1471,8 +1544,8 @@ instance ( tx ~ GenTx blk , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) , Show (TxId (GenTx blk)) - , LogFormatting (InvalidBlockReason blk) , LogFormatting (CannotForge blk) + , LogFormatting (ExtValidationError blk) , LogFormatting (ForgeStateUpdateError blk)) => LogFormatting (TraceForgeEvent blk) where forMachine _dtal (TraceStartLeadershipCheck slotNo) = diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs index 72d69e6a1f6..5c95b2c8a01 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs @@ -19,9 +19,9 @@ import Cardano.Logging import Data.Aeson (Value (String), (.=)) import Data.Text (pack) import Formatting -import Network.Mux (MuxTrace (..), WithMuxBearer (..)) -import Network.Mux.Types -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) +import qualified Network.Mux as Mux +import Network.Mux.Types (SDUHeader (..), unRemoteClockModel) +import Network.TypedProtocol.Codec (AnyMessage (AnyMessageAndAgency)) import qualified Data.List as List import qualified Ouroboros.Network.Diffusion as ND @@ -36,52 +36,52 @@ import Cardano.Node.Configuration.TopologyP2P () -- Mux Tracer -------------------------------------------------------------------------------- -instance (LogFormatting peer, LogFormatting MuxTrace) => - LogFormatting (WithMuxBearer peer MuxTrace) where - forMachine dtal (WithMuxBearer b ev) = - mconcat [ "kind" .= String "MuxTrace" +instance (LogFormatting peer, LogFormatting Mux.Trace) => + LogFormatting (Mux.WithBearer peer Mux.Trace) where + forMachine dtal (Mux.WithBearer b ev) = + mconcat [ "kind" .= String "Mux.Trace" , "bearer" .= forMachine dtal b , "event" .= forMachine dtal ev ] - forHuman (WithMuxBearer b ev) = "With mux bearer " <> forHumanOrMachine b + forHuman (Mux.WithBearer b ev) = "With mux bearer " <> forHumanOrMachine b <> ". " <> forHumanOrMachine ev -instance MetaTrace tr => MetaTrace (WithMuxBearer peer tr) where - namespaceFor (WithMuxBearer _peer obj) = (nsCast . namespaceFor) obj +instance MetaTrace tr => MetaTrace (Mux.WithBearer peer tr) where + namespaceFor (Mux.WithBearer _peer obj) = (nsCast . namespaceFor) obj severityFor ns Nothing = severityFor (nsCast ns :: Namespace tr) Nothing - severityFor ns (Just (WithMuxBearer _peer obj)) = + severityFor ns (Just (Mux.WithBearer _peer obj)) = severityFor (nsCast ns) (Just obj) privacyFor ns Nothing = privacyFor (nsCast ns :: Namespace tr) Nothing - privacyFor ns (Just (WithMuxBearer _peer obj)) = + privacyFor ns (Just (Mux.WithBearer _peer obj)) = privacyFor (nsCast ns) (Just obj) detailsFor ns Nothing = detailsFor (nsCast ns :: Namespace tr) Nothing - detailsFor ns (Just (WithMuxBearer _peer obj)) = + detailsFor ns (Just (Mux.WithBearer _peer obj)) = detailsFor (nsCast ns) (Just obj) documentFor ns = documentFor (nsCast ns :: Namespace tr) metricsDocFor ns = metricsDocFor (nsCast ns :: Namespace tr) allNamespaces = map nsCast (allNamespaces :: [Namespace tr]) -instance LogFormatting MuxTrace where - forMachine _dtal MuxTraceRecvHeaderStart = mconcat - [ "kind" .= String "MuxTraceRecvHeaderStart" +instance LogFormatting Mux.Trace where + forMachine _dtal Mux.TraceRecvHeaderStart = mconcat + [ "kind" .= String "Mux.TraceRecvHeaderStart" , "msg" .= String "Bearer Receive Header Start" ] - forMachine _dtal (MuxTraceRecvHeaderEnd MuxSDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat - [ "kind" .= String "MuxTraceRecvHeaderStart" + forMachine _dtal (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + [ "kind" .= String "Mux.TraceRecvHeaderStart" , "msg" .= String "Bearer Receive Header End" , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) , "miniProtocolNum" .= String (showT mhNum) , "miniProtocolDir" .= String (showT mhDir) , "length" .= String (showT mhLength) ] - forMachine _dtal (MuxTraceRecvDeltaQObservation MuxSDUHeader { mhTimestamp, mhLength } ts) = mconcat - [ "kind" .= String "MuxTraceRecvDeltaQObservation" + forMachine _dtal (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = mconcat + [ "kind" .= String "Mux.TraceRecvDeltaQObservation" , "msg" .= String "Bearer DeltaQ observation" , "timeRemote" .= String (showT ts) , "timeLocal" .= String (showTHex (unRemoteClockModel mhTimestamp)) , "length" .= String (showT mhLength) ] - forMachine _dtal (MuxTraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = mconcat - [ "kind" .= String "MuxTraceRecvDeltaQSample" + forMachine _dtal (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = mconcat + [ "kind" .= String "Mux.TraceRecvDeltaQSample" , "msg" .= String "Bearer DeltaQ Sample" , "duration" .= String (showT d) , "packets" .= String (showT sp) @@ -92,83 +92,83 @@ instance LogFormatting MuxTrace where , "DeltaQ_estR" .= String (showT estR) , "sizeDist" .= String (showT sdud) ] - forMachine _dtal (MuxTraceRecvStart len) = mconcat - [ "kind" .= String "MuxTraceRecvStart" + forMachine _dtal (Mux.TraceRecvStart len) = mconcat + [ "kind" .= String "Mux.TraceRecvStart" , "msg" .= String "Bearer Receive Start" , "length" .= String (showT len) ] - forMachine _dtal (MuxTraceRecvEnd len) = mconcat - [ "kind" .= String "MuxTraceRecvEnd" + forMachine _dtal (Mux.TraceRecvEnd len) = mconcat + [ "kind" .= String "Mux.TraceRecvEnd" , "msg" .= String "Bearer Receive End" , "length" .= String (showT len) ] - forMachine _dtal (MuxTraceSendStart MuxSDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat - [ "kind" .= String "MuxTraceSendStart" + forMachine _dtal (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + [ "kind" .= String "Mux.TraceSendStart" , "msg" .= String "Bearer Send Start" , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) , "miniProtocolNum" .= String (showT mhNum) , "miniProtocolDir" .= String (showT mhDir) , "length" .= String (showT mhLength) ] - forMachine _dtal MuxTraceSendEnd = mconcat - [ "kind" .= String "MuxTraceSendEnd" + forMachine _dtal Mux.TraceSendEnd = mconcat + [ "kind" .= String "Mux.TraceSendEnd" , "msg" .= String "Bearer Send End" ] - forMachine _dtal (MuxTraceState new) = mconcat - [ "kind" .= String "MuxTraceState" + forMachine _dtal (Mux.TraceState new) = mconcat + [ "kind" .= String "Mux.TraceState" , "msg" .= String "MuxState" , "state" .= String (showT new) ] - forMachine _dtal (MuxTraceCleanExit mid dir) = mconcat - [ "kind" .= String "MuxTraceCleanExit" + forMachine _dtal (Mux.TraceCleanExit mid dir) = mconcat + [ "kind" .= String "Mux.TraceCleanExit" , "msg" .= String "Miniprotocol terminated cleanly" , "miniProtocolNum" .= String (showT mid) , "miniProtocolDir" .= String (showT dir) ] - forMachine _dtal (MuxTraceExceptionExit mid dir exc) = mconcat - [ "kind" .= String "MuxTraceExceptionExit" + forMachine _dtal (Mux.TraceExceptionExit mid dir exc) = mconcat + [ "kind" .= String "Mux.TraceExceptionExit" , "msg" .= String "Miniprotocol terminated with exception" , "miniProtocolNum" .= String (showT mid) , "miniProtocolDir" .= String (showT dir) , "exception" .= String (showT exc) ] - forMachine _dtal (MuxTraceChannelRecvStart mid) = mconcat - [ "kind" .= String "MuxTraceChannelRecvStart" + forMachine _dtal (Mux.TraceChannelRecvStart mid) = mconcat + [ "kind" .= String "Mux.TraceChannelRecvStart" , "msg" .= String "Channel Receive Start" , "miniProtocolNum" .= String (showT mid) ] - forMachine _dtal (MuxTraceChannelRecvEnd mid len) = mconcat - [ "kind" .= String "MuxTraceChannelRecvEnd" + forMachine _dtal (Mux.TraceChannelRecvEnd mid len) = mconcat + [ "kind" .= String "Mux.TraceChannelRecvEnd" , "msg" .= String "Channel Receive End" , "miniProtocolNum" .= String (showT mid) , "length" .= String (showT len) ] - forMachine _dtal (MuxTraceChannelSendStart mid len) = mconcat - [ "kind" .= String "MuxTraceChannelSendStart" + forMachine _dtal (Mux.TraceChannelSendStart mid len) = mconcat + [ "kind" .= String "Mux.TraceChannelSendStart" , "msg" .= String "Channel Send Start" , "miniProtocolNum" .= String (showT mid) , "length" .= String (showT len) ] - forMachine _dtal (MuxTraceChannelSendEnd mid) = mconcat - [ "kind" .= String "MuxTraceChannelSendEnd" + forMachine _dtal (Mux.TraceChannelSendEnd mid) = mconcat + [ "kind" .= String "Mux.TraceChannelSendEnd" , "msg" .= String "Channel Send End" , "miniProtocolNum" .= String (showT mid) ] - forMachine _dtal MuxTraceHandshakeStart = mconcat - [ "kind" .= String "MuxTraceHandshakeStart" + forMachine _dtal Mux.TraceHandshakeStart = mconcat + [ "kind" .= String "Mux.TraceHandshakeStart" , "msg" .= String "Handshake start" ] - forMachine _dtal (MuxTraceHandshakeClientEnd duration) = mconcat - [ "kind" .= String "MuxTraceHandshakeClientEnd" + forMachine _dtal (Mux.TraceHandshakeClientEnd duration) = mconcat + [ "kind" .= String "Mux.TraceHandshakeClientEnd" , "msg" .= String "Handshake Client end" , "duration" .= String (showT duration) ] - forMachine _dtal MuxTraceHandshakeServerEnd = mconcat - [ "kind" .= String "MuxTraceHandshakeServerEnd" + forMachine _dtal Mux.TraceHandshakeServerEnd = mconcat + [ "kind" .= String "Mux.TraceHandshakeServerEnd" , "msg" .= String "Handshake Server end" ] - forMachine dtal (MuxTraceHandshakeClientError e duration) = mconcat - [ "kind" .= String "MuxTraceHandshakeClientError" + forMachine dtal (Mux.TraceHandshakeClientError e duration) = mconcat + [ "kind" .= String "Mux.TraceHandshakeClientError" , "msg" .= String "Handshake Client Error" , "duration" .= String (showT duration) -- Client Error can include an error string from the peer which could be very large. @@ -176,59 +176,59 @@ instance LogFormatting MuxTrace where then show e else take 256 $ show e ] - forMachine dtal (MuxTraceHandshakeServerError e) = mconcat - [ "kind" .= String "MuxTraceHandshakeServerError" + forMachine dtal (Mux.TraceHandshakeServerError e) = mconcat + [ "kind" .= String "Mux.TraceHandshakeServerError" , "msg" .= String "Handshake Server Error" , "error" .= if dtal >= DDetailed then show e else take 256 $ show e ] - forMachine _dtal MuxTraceSDUReadTimeoutException = mconcat - [ "kind" .= String "MuxTraceSDUReadTimeoutException" + forMachine _dtal Mux.TraceSDUReadTimeoutException = mconcat + [ "kind" .= String "Mux.TraceSDUReadTimeoutException" , "msg" .= String "Timed out reading SDU" ] - forMachine _dtal MuxTraceSDUWriteTimeoutException = mconcat - [ "kind" .= String "MuxTraceSDUWriteTimeoutException" + forMachine _dtal Mux.TraceSDUWriteTimeoutException = mconcat + [ "kind" .= String "Mux.TraceSDUWriteTimeoutException" , "msg" .= String "Timed out writing SDU" ] - forMachine _dtal (MuxTraceStartEagerly mid dir) = mconcat - [ "kind" .= String "MuxTraceStartEagerly" + forMachine _dtal (Mux.TraceStartEagerly mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartEagerly" , "msg" .= String "Eagerly started" , "miniProtocolNum" .= String (showT mid) , "miniProtocolDir" .= String (showT dir) ] - forMachine _dtal (MuxTraceStartOnDemand mid dir) = mconcat - [ "kind" .= String "MuxTraceStartOnDemand" + forMachine _dtal (Mux.TraceStartOnDemand mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartOnDemand" , "msg" .= String "Preparing to start" , "miniProtocolNum" .= String (showT mid) , "miniProtocolDir" .= String (showT dir) ] - forMachine _dtal (MuxTraceStartedOnDemand mid dir) = mconcat - [ "kind" .= String "MuxTraceStartedOnDemand" + forMachine _dtal (Mux.TraceStartedOnDemand mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartedOnDemand" , "msg" .= String "Started on demand" , "miniProtocolNum" .= String (showT mid) , "miniProtocolDir" .= String (showT dir) ] - forMachine _dtal (MuxTraceTerminating mid dir) = mconcat - [ "kind" .= String "MuxTraceTerminating" + forMachine _dtal (Mux.TraceTerminating mid dir) = mconcat + [ "kind" .= String "Mux.TraceTerminating" , "msg" .= String "Terminating" , "miniProtocolNum" .= String (showT mid) , "miniProtocolDir" .= String (showT dir) ] - forMachine _dtal MuxTraceStopping = mconcat - [ "kind" .= String "MuxTraceStopping" + forMachine _dtal Mux.TraceStopping = mconcat + [ "kind" .= String "Mux.TraceStopping" , "msg" .= String "Mux stopping" ] - forMachine _dtal MuxTraceStopped = mconcat - [ "kind" .= String "MuxTraceStopped" + forMachine _dtal Mux.TraceStopped = mconcat + [ "kind" .= String "Mux.TraceStopped" , "msg" .= String "Mux stoppped" ] #ifdef os_HOST_linux - forMachine _dtal (MuxTraceTCPInfo StructTCPInfo + forMachine _dtal (Mux.TraceTCPInfo StructTCPInfo { tcpi_snd_mss, tcpi_rcv_mss, tcpi_lost, tcpi_retrans , tcpi_rtt, tcpi_rttvar, tcpi_snd_cwnd } len) = - [ "kind" .= String "MuxTraceTCPInfo" + [ "kind" .= String "Mux.TraceTCPInfo" , "msg" .= String "TCPInfo" , "rtt" .= String (show (fromIntegral tcpi_rtt :: Word)) , "rttvar" .= String (show (fromIntegral tcpi_rttvar :: Word)) @@ -240,79 +240,79 @@ instance LogFormatting MuxTrace where , "length" .= String (showT len) ] #else - forMachine _dtal (MuxTraceTCPInfo _ len) = mconcat - [ "kind" .= String "MuxTraceTCPInfo" + forMachine _dtal (Mux.TraceTCPInfo _ len) = mconcat + [ "kind" .= String "Mux.TraceTCPInfo" , "msg" .= String "TCPInfo" , "len" .= String (showT len) ] #endif - forHuman MuxTraceRecvHeaderStart = + forHuman Mux.TraceRecvHeaderStart = "Bearer Receive Header Start" - forHuman (MuxTraceRecvHeaderEnd MuxSDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = + forHuman (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = sformat ("Bearer Receive Header End: ts:" % prefixHex % "(" % shown % ") " % shown % " len " % int) (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength - forHuman (MuxTraceRecvDeltaQObservation MuxSDUHeader { mhTimestamp, mhLength } ts) = + forHuman (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = sformat ("Bearer DeltaQ observation: remote ts" % int % " local ts " % shown % " length " % int) (unRemoteClockModel mhTimestamp) ts mhLength - forHuman (MuxTraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = + forHuman (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = sformat ("Bearer DeltaQ Sample: duration " % fixed 3 % " packets " % int % " sumBytes " % int % " DeltaQ_S " % fixed 3 % " DeltaQ_VMean " % fixed 3 % "DeltaQ_VVar " % fixed 3 % " DeltaQ_estR " % fixed 3 % " sizeDist " % string) d sp so dqs dqvm dqvs estR sdud - forHuman (MuxTraceRecvStart len) = + forHuman (Mux.TraceRecvStart len) = sformat ("Bearer Receive Start: length " % int) len - forHuman (MuxTraceRecvEnd len) = + forHuman (Mux.TraceRecvEnd len) = sformat ("Bearer Receive End: length " % int) len - forHuman (MuxTraceSendStart MuxSDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = + forHuman (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = sformat ("Bearer Send Start: ts: " % prefixHex % " (" % shown % ") " % shown % " length " % int) (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength - forHuman MuxTraceSendEnd = + forHuman Mux.TraceSendEnd = "Bearer Send End" - forHuman (MuxTraceState new) = + forHuman (Mux.TraceState new) = sformat ("State: " % shown) new - forHuman (MuxTraceCleanExit mid dir) = + forHuman (Mux.TraceCleanExit mid dir) = sformat ("Miniprotocol (" % shown % ") " % shown % " terminated cleanly") mid dir - forHuman (MuxTraceExceptionExit mid dir e) = + forHuman (Mux.TraceExceptionExit mid dir e) = sformat ("Miniprotocol (" % shown % ") " % shown % " terminated with exception " % shown) mid dir e - forHuman (MuxTraceChannelRecvStart mid) = + forHuman (Mux.TraceChannelRecvStart mid) = sformat ("Channel Receive Start on " % shown) mid - forHuman (MuxTraceChannelRecvEnd mid len) = + forHuman (Mux.TraceChannelRecvEnd mid len) = sformat ("Channel Receive End on (" % shown % ") " % int) mid len - forHuman (MuxTraceChannelSendStart mid len) = + forHuman (Mux.TraceChannelSendStart mid len) = sformat ("Channel Send Start on (" % shown % ") " % int) mid len - forHuman (MuxTraceChannelSendEnd mid) = + forHuman (Mux.TraceChannelSendEnd mid) = sformat ("Channel Send End on " % shown) mid - forHuman MuxTraceHandshakeStart = + forHuman Mux.TraceHandshakeStart = "Handshake start" - forHuman (MuxTraceHandshakeClientEnd duration) = + forHuman (Mux.TraceHandshakeClientEnd duration) = sformat ("Handshake Client end, duration " % shown) duration - forHuman MuxTraceHandshakeServerEnd = + forHuman Mux.TraceHandshakeServerEnd = "Handshake Server end" - forHuman (MuxTraceHandshakeClientError e duration) = + forHuman (Mux.TraceHandshakeClientError e duration) = -- Client Error can include an error string from the peer which could be very large. sformat ("Handshake Client Error " % string % " duration " % shown) (take 256 $ show e) duration - forHuman (MuxTraceHandshakeServerError e) = + forHuman (Mux.TraceHandshakeServerError e) = sformat ("Handshake Server Error " % shown) e - forHuman MuxTraceSDUReadTimeoutException = + forHuman Mux.TraceSDUReadTimeoutException = "Timed out reading SDU" - forHuman MuxTraceSDUWriteTimeoutException = + forHuman Mux.TraceSDUWriteTimeoutException = "Timed out writing SDU" - forHuman (MuxTraceStartEagerly mid dir) = + forHuman (Mux.TraceStartEagerly mid dir) = sformat ("Eagerly started (" % shown % ") in " % shown) mid dir - forHuman (MuxTraceStartOnDemand mid dir) = + forHuman (Mux.TraceStartOnDemand mid dir) = sformat ("Preparing to start (" % shown % ") in " % shown) mid dir - forHuman (MuxTraceStartedOnDemand mid dir) = + forHuman (Mux.TraceStartedOnDemand mid dir) = sformat ("Started on demand (" % shown % ") in " % shown) mid dir - forHuman (MuxTraceTerminating mid dir) = + forHuman (Mux.TraceTerminating mid dir) = sformat ("Terminating (" % shown % ") in " % shown) mid dir - forHuman MuxTraceStopping = "Mux stopping" - forHuman MuxTraceStopped = "Mux stoppped" + forHuman Mux.TraceStopping = "Mux stopping" + forHuman Mux.TraceStopped = "Mux stoppped" #ifdef os_HOST_linux - forHuman (MuxTraceTCPInfo StructTCPInfo + forHuman (Mux.TraceTCPInfo StructTCPInfo { tcpi_snd_mss, tcpi_rcv_mss, tcpi_lost, tcpi_retrans , tcpi_rtt, tcpi_rttvar, tcpi_snd_cwnd } len) = @@ -325,67 +325,67 @@ instance LogFormatting MuxTrace where (fromIntegral tcpi_retrans :: Word) len #else - forHuman (MuxTraceTCPInfo _ len) = sformat ("TCPInfo len " % int) len + forHuman (Mux.TraceTCPInfo _ len) = sformat ("TCPInfo len " % int) len #endif -instance MetaTrace MuxTrace where - namespaceFor MuxTraceRecvHeaderStart {} = +instance MetaTrace Mux.Trace where + namespaceFor Mux.TraceRecvHeaderStart {} = Namespace [] ["RecvHeaderStart"] - namespaceFor MuxTraceRecvHeaderEnd {} = + namespaceFor Mux.TraceRecvHeaderEnd {} = Namespace [] ["RecvHeaderEnd"] - namespaceFor MuxTraceRecvStart {} = + namespaceFor Mux.TraceRecvStart {} = Namespace [] ["RecvStart"] - namespaceFor MuxTraceRecvEnd {} = + namespaceFor Mux.TraceRecvEnd {} = Namespace [] ["RecvEnd"] - namespaceFor MuxTraceSendStart {} = + namespaceFor Mux.TraceSendStart {} = Namespace [] ["SendStart"] - namespaceFor MuxTraceSendEnd = + namespaceFor Mux.TraceSendEnd = Namespace [] ["SendEnd"] - namespaceFor MuxTraceState {} = + namespaceFor Mux.TraceState {} = Namespace [] ["State"] - namespaceFor MuxTraceCleanExit {} = + namespaceFor Mux.TraceCleanExit {} = Namespace [] ["CleanExit"] - namespaceFor MuxTraceExceptionExit {} = + namespaceFor Mux.TraceExceptionExit {} = Namespace [] ["ExceptionExit"] - namespaceFor MuxTraceChannelRecvStart {} = + namespaceFor Mux.TraceChannelRecvStart {} = Namespace [] ["ChannelRecvStart"] - namespaceFor MuxTraceChannelRecvEnd {} = + namespaceFor Mux.TraceChannelRecvEnd {} = Namespace [] ["ChannelRecvEnd"] - namespaceFor MuxTraceChannelSendStart {} = + namespaceFor Mux.TraceChannelSendStart {} = Namespace [] ["ChannelSendStart"] - namespaceFor MuxTraceChannelSendEnd {} = + namespaceFor Mux.TraceChannelSendEnd {} = Namespace [] ["ChannelSendEnd"] - namespaceFor MuxTraceHandshakeStart = + namespaceFor Mux.TraceHandshakeStart = Namespace [] ["HandshakeStart"] - namespaceFor MuxTraceHandshakeClientEnd {} = + namespaceFor Mux.TraceHandshakeClientEnd {} = Namespace [] ["HandshakeClientEnd"] - namespaceFor MuxTraceHandshakeServerEnd = + namespaceFor Mux.TraceHandshakeServerEnd = Namespace [] ["HandshakeServerEnd"] - namespaceFor MuxTraceHandshakeClientError {} = + namespaceFor Mux.TraceHandshakeClientError {} = Namespace [] ["HandshakeClientError"] - namespaceFor MuxTraceHandshakeServerError {} = + namespaceFor Mux.TraceHandshakeServerError {} = Namespace [] ["HandshakeServerError"] - namespaceFor MuxTraceRecvDeltaQObservation {} = + namespaceFor Mux.TraceRecvDeltaQObservation {} = Namespace [] ["RecvDeltaQObservation"] - namespaceFor MuxTraceRecvDeltaQSample {} = + namespaceFor Mux.TraceRecvDeltaQSample {} = Namespace [] ["RecvDeltaQSample"] - namespaceFor MuxTraceSDUReadTimeoutException = + namespaceFor Mux.TraceSDUReadTimeoutException = Namespace [] ["SDUReadTimeoutException"] - namespaceFor MuxTraceSDUWriteTimeoutException = + namespaceFor Mux.TraceSDUWriteTimeoutException = Namespace [] ["SDUWriteTimeoutException"] - namespaceFor MuxTraceStartEagerly {} = + namespaceFor Mux.TraceStartEagerly {} = Namespace [] ["StartEagerly"] - namespaceFor MuxTraceStartOnDemand {} = + namespaceFor Mux.TraceStartOnDemand {} = Namespace [] ["StartOnDemand"] - namespaceFor MuxTraceStartedOnDemand {} = + namespaceFor Mux.TraceStartedOnDemand {} = Namespace [] ["StartedOnDemand"] - namespaceFor MuxTraceTerminating {} = + namespaceFor Mux.TraceTerminating {} = Namespace [] ["Terminating"] - namespaceFor MuxTraceStopping = + namespaceFor Mux.TraceStopping = Namespace [] ["Stopping"] - namespaceFor MuxTraceStopped = + namespaceFor Mux.TraceStopped = Namespace [] ["Stopped"] - namespaceFor MuxTraceTCPInfo {} = + namespaceFor Mux.TraceTCPInfo {} = Namespace [] ["TCPInfo"] severityFor (Namespace _ ["RecvHeaderStart"]) _ = Just Debug @@ -520,14 +520,14 @@ instance MetaTrace MuxTrace where -------------------------------------------------------------------------------- instance (Show adr, Show ver) => LogFormatting (NtN.HandshakeTr adr ver) where - forMachine _dtal (WithMuxBearer b ev) = + forMachine _dtal (Mux.WithBearer b ev) = mconcat [ "kind" .= String "HandshakeTrace" , "bearer" .= show b , "event" .= show ev ] - forHuman (WithMuxBearer b ev) = "With mux bearer " <> showT b + forHuman (Mux.WithBearer b ev) = "With mux bearer " <> showT b <> ". " <> showT ev -instance MetaTrace (AnyMessageAndAgency (HS.Handshake nt term)) where +instance MetaTrace (AnyMessage (HS.Handshake nt term)) where namespaceFor (AnyMessageAndAgency _stok HS.MsgProposeVersions {}) = Namespace [] ["ProposeVersions"] namespaceFor (AnyMessageAndAgency _stok HS.MsgReplyVersions {}) = @@ -851,6 +851,10 @@ instance LogFormatting TraceLedgerPeers where , "domainAccessPoint" .= show dap , "error" .= show reason ] + forMachine _dtal UsingBigLedgerPeerSnapshot = + mconcat + [ "kind" .= String "UsingBigLedgerPeerSnapshot" + ] instance MetaTrace TraceLedgerPeers where namespaceFor PickedLedgerPeer {} = @@ -885,6 +889,8 @@ instance MetaTrace TraceLedgerPeers where Namespace [] ["TraceLedgerPeersResult"] namespaceFor TraceLedgerPeersFailure {} = Namespace [] ["TraceLedgerPeersFailure"] + namespaceFor UsingBigLedgerPeerSnapshot {} = + Namespace [] ["UsingBigLedgerPeerSnapshot"] severityFor (Namespace _ ["PickedPeer"]) _ = Just Debug severityFor (Namespace _ ["PickedPeers"]) _ = Just Info @@ -900,6 +906,7 @@ instance MetaTrace TraceLedgerPeers where severityFor (Namespace _ ["TraceLedgerPeersDomains"]) _ = Just Debug severityFor (Namespace _ ["TraceLedgerPeersResult"]) _ = Just Debug severityFor (Namespace _ ["TraceLedgerPeersFailure"]) _ = Just Debug + severityFor (Namespace _ ["UsingBigLedgerPeerSnapshot"]) _ = Just Debug severityFor _ _ = Nothing documentFor (Namespace _ ["PickedPeer"]) = Just @@ -928,6 +935,9 @@ instance MetaTrace TraceLedgerPeers where "" documentFor (Namespace _ ["TraceLedgerPeersFailure"]) = Just "" + documentFor (Namespace _ ["UsingBigLedgerPeerSnapshot"]) = Just $ mconcat + [ "Trace for when a request for big ledger peers is fulfilled from the snapshot file" + , " defined in the topology configuration file."] documentFor _ = Nothing allNamespaces = [ @@ -943,4 +953,5 @@ instance MetaTrace TraceLedgerPeers where , Namespace [] ["TraceLedgerPeersDomains"] , Namespace [] ["TraceLedgerPeersResult"] , Namespace [] ["TraceLedgerPeersFailure"] + , Namespace [] ["UsingBigLedgerPeerSnapshot"] ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs index 870de3235ca..71f03104b4b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs @@ -12,7 +12,8 @@ module Cardano.Node.Tracing.Tracers.NodeToClient () where import Cardano.Logging import Ouroboros.Consensus.Ledger.Query (Query) -import Ouroboros.Network.Driver.Simple (TraceSendRecv (..)) +import qualified Ouroboros.Network.Driver.Simple as Simple +import qualified Ouroboros.Network.Driver.Stateful as Stateful import Ouroboros.Network.Protocol.ChainSync.Type as ChainSync import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LSQ import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LTM @@ -20,75 +21,141 @@ import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS import Data.Aeson (Value (String), (.=)) import Data.Text (Text, pack) -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) +import qualified Network.TypedProtocol.Codec as Simple +import qualified Network.TypedProtocol.Stateful.Codec as Stateful {-# ANN module ("HLint: ignore Redundant bracket" :: Text) #-} +instance LogFormatting (Simple.AnyMessage ps) + => LogFormatting (Simple.TraceSendRecv ps) where + forMachine dtal (Simple.TraceSendMsg m) = mconcat + [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] + forMachine dtal (Simple.TraceRecvMsg m) = mconcat + [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ] + + forHuman (Simple.TraceSendMsg m) = "Send: " <> forHumanOrMachine m + forHuman (Simple.TraceRecvMsg m) = "Receive: " <> forHumanOrMachine m -instance LogFormatting (AnyMessageAndAgency ps) - => LogFormatting (TraceSendRecv ps) where - forMachine dtal (TraceSendMsg m) = mconcat + asMetrics (Simple.TraceSendMsg m) = asMetrics m + asMetrics (Simple.TraceRecvMsg m) = asMetrics m + +instance LogFormatting (Stateful.AnyMessage ps f) + => LogFormatting (Stateful.TraceSendRecv ps f) where + forMachine dtal (Stateful.TraceSendMsg m) = mconcat [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] - forMachine dtal (TraceRecvMsg m) = mconcat + forMachine dtal (Stateful.TraceRecvMsg m) = mconcat [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ] - forHuman (TraceSendMsg m) = "Send: " <> forHumanOrMachine m - forHuman (TraceRecvMsg m) = "Receive: " <> forHumanOrMachine m + forHuman (Stateful.TraceSendMsg m) = "Send: " <> forHumanOrMachine m + forHuman (Stateful.TraceRecvMsg m) = "Receive: " <> forHumanOrMachine m + + asMetrics (Stateful.TraceSendMsg m) = asMetrics m + asMetrics (Stateful.TraceRecvMsg m) = asMetrics m + +instance MetaTrace (Simple.AnyMessage ps) => + MetaTrace (Simple.TraceSendRecv ps) where + namespaceFor (Simple.TraceSendMsg msg) = + nsPrependInner "Send" (namespaceFor msg) + namespaceFor (Simple.TraceRecvMsg msg) = + nsPrependInner "Receive" (namespaceFor msg) + + severityFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = + severityFor (Namespace out tl) (Just msg) + severityFor (Namespace out ("Send" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + severityFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = + severityFor (Namespace out tl) (Just msg) + severityFor (Namespace out ("Receive" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + severityFor _ _ = Nothing + + privacyFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = + privacyFor (Namespace out tl) (Just msg) + privacyFor (Namespace out ("Send" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + privacyFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = + privacyFor (Namespace out tl) (Just msg) + privacyFor (Namespace out ("Receive" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + privacyFor _ _ = Nothing + + detailsFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = + detailsFor (Namespace out tl) (Just msg) + detailsFor (Namespace out ("Send" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + detailsFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = + detailsFor (Namespace out tl) (Just msg) + detailsFor (Namespace out ("Receive" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + detailsFor _ _ = Nothing + + metricsDocFor (Namespace out ("Send" : tl)) = + metricsDocFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) + metricsDocFor (Namespace out ("Receive" : tl)) = + metricsDocFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) + metricsDocFor _ = [] + + documentFor (Namespace out ("Send" : tl)) = + documentFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) + documentFor (Namespace out ("Receive" : tl)) = + documentFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) + documentFor _ = Nothing - asMetrics (TraceSendMsg m) = asMetrics m - asMetrics (TraceRecvMsg m) = asMetrics m + allNamespaces = + let cn = allNamespaces :: [Namespace (Simple.AnyMessage ps)] + in fmap (nsPrependInner "Send") cn ++ fmap (nsPrependInner "Receive") cn -instance MetaTrace (AnyMessageAndAgency ps) => - MetaTrace (TraceSendRecv ps) where - namespaceFor (TraceSendMsg msg) = +instance MetaTrace (Stateful.AnyMessage ps f) => + MetaTrace (Stateful.TraceSendRecv ps f) where + namespaceFor (Stateful.TraceSendMsg msg) = nsPrependInner "Send" (namespaceFor msg) - namespaceFor (TraceRecvMsg msg) = + namespaceFor (Stateful.TraceRecvMsg msg) = nsPrependInner "Receive" (namespaceFor msg) - severityFor (Namespace out ("Send" : tl)) (Just (TraceSendMsg msg)) = + severityFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = severityFor (Namespace out tl) (Just msg) severityFor (Namespace out ("Send" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing - severityFor (Namespace out ("Receive" : tl)) (Just (TraceSendMsg msg)) = + severityFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing + severityFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = severityFor (Namespace out tl) (Just msg) severityFor (Namespace out ("Receive" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing + severityFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing severityFor _ _ = Nothing - privacyFor (Namespace out ("Send" : tl)) (Just (TraceSendMsg msg)) = + privacyFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = privacyFor (Namespace out tl) (Just msg) privacyFor (Namespace out ("Send" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing - privacyFor (Namespace out ("Receive" : tl)) (Just (TraceSendMsg msg)) = + privacyFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing + privacyFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = privacyFor (Namespace out tl) (Just msg) privacyFor (Namespace out ("Receive" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing + privacyFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing privacyFor _ _ = Nothing - detailsFor (Namespace out ("Send" : tl)) (Just (TraceSendMsg msg)) = + detailsFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = detailsFor (Namespace out tl) (Just msg) detailsFor (Namespace out ("Send" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing - detailsFor (Namespace out ("Receive" : tl)) (Just (TraceSendMsg msg)) = + detailsFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing + detailsFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = detailsFor (Namespace out tl) (Just msg) detailsFor (Namespace out ("Receive" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing + detailsFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing detailsFor _ _ = Nothing metricsDocFor (Namespace out ("Send" : tl)) = - metricsDocFor (nsCast (Namespace out tl) :: Namespace (AnyMessageAndAgency ps)) + metricsDocFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) metricsDocFor (Namespace out ("Receive" : tl)) = - metricsDocFor (nsCast (Namespace out tl) :: Namespace (AnyMessageAndAgency ps)) + metricsDocFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) metricsDocFor _ = [] documentFor (Namespace out ("Send" : tl)) = - documentFor (nsCast (Namespace out tl) :: Namespace (AnyMessageAndAgency ps)) + documentFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) documentFor (Namespace out ("Receive" : tl)) = - documentFor (nsCast (Namespace out tl) :: Namespace (AnyMessageAndAgency ps)) + documentFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) documentFor _ = Nothing allNamespaces = - let cn = allNamespaces :: [Namespace (AnyMessageAndAgency ps)] + let cn = allNamespaces :: [Namespace (Stateful.AnyMessage ps f)] in fmap (nsPrependInner "Send") cn ++ fmap (nsPrependInner "Receive") cn @@ -96,56 +163,56 @@ instance MetaTrace (AnyMessageAndAgency ps) => -- -- TChainSync Tracer -- -------------------------------------------------------------------------------- -instance LogFormatting (AnyMessageAndAgency (ChainSync blk pt tip)) where - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRequestNext{}) = +instance LogFormatting (Simple.AnyMessage (ChainSync blk pt tip)) where + forMachine _dtal (Simple.AnyMessageAndAgency stok ChainSync.MsgRequestNext{}) = mconcat [ "kind" .= String "MsgRequestNext" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgAwaitReply{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok ChainSync.MsgAwaitReply{}) = mconcat [ "kind" .= String "MsgAwaitReply" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRollForward{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok ChainSync.MsgRollForward{}) = mconcat [ "kind" .= String "MsgRollForward" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRollBackward{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok ChainSync.MsgRollBackward{}) = mconcat [ "kind" .= String "MsgRollBackward" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgFindIntersect{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok ChainSync.MsgFindIntersect{}) = mconcat [ "kind" .= String "MsgFindIntersect" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgIntersectFound{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok ChainSync.MsgIntersectFound{}) = mconcat [ "kind" .= String "MsgIntersectFound" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgIntersectNotFound{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok ChainSync.MsgIntersectNotFound{}) = mconcat [ "kind" .= String "MsgIntersectNotFound" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgDone{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok ChainSync.MsgDone{}) = mconcat [ "kind" .= String "MsgDone" , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (ChainSync blk pt tip)) where - namespaceFor (AnyMessageAndAgency _agency (MsgRequestNext {})) = +instance MetaTrace (Simple.AnyMessage (ChainSync blk pt tip)) where + namespaceFor (Simple.AnyMessageAndAgency _agency (MsgRequestNext {})) = Namespace [] ["RequestNext"] - namespaceFor (AnyMessageAndAgency _agency (MsgAwaitReply {})) = + namespaceFor (Simple.AnyMessageAndAgency _agency (MsgAwaitReply {})) = Namespace [] ["AwaitReply"] - namespaceFor (AnyMessageAndAgency _agency (MsgRollForward {})) = + namespaceFor (Simple.AnyMessageAndAgency _agency (MsgRollForward {})) = Namespace [] ["RollForward"] - namespaceFor (AnyMessageAndAgency _agency (MsgRollBackward {})) = + namespaceFor (Simple.AnyMessageAndAgency _agency (MsgRollBackward {})) = Namespace [] ["RollBackward"] - namespaceFor (AnyMessageAndAgency _agency (MsgFindIntersect {})) = + namespaceFor (Simple.AnyMessageAndAgency _agency (MsgFindIntersect {})) = Namespace [] ["FindIntersect"] - namespaceFor (AnyMessageAndAgency _agency (MsgIntersectFound {})) = + namespaceFor (Simple.AnyMessageAndAgency _agency (MsgIntersectFound {})) = Namespace [] ["IntersectFound"] - namespaceFor (AnyMessageAndAgency _agency (MsgIntersectNotFound {})) = + namespaceFor (Simple.AnyMessageAndAgency _agency (MsgIntersectNotFound {})) = Namespace [] ["IntersectNotFound"] - namespaceFor (AnyMessageAndAgency _agency (MsgDone {})) = + namespaceFor (Simple.AnyMessageAndAgency _agency (MsgDone {})) = Namespace [] ["Done"] severityFor (Namespace _ ["RequestNext"]) _ = Just Info @@ -220,74 +287,74 @@ instance MetaTrace (AnyMessageAndAgency (ChainSync blk pt tip)) where -- LocalTxMonitor Tracer -------------------------------------------------------------------------------- -instance LogFormatting (AnyMessageAndAgency (LTM.LocalTxMonitor txid tx slotNo)) where - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgAcquire {}) = +instance LogFormatting (Simple.AnyMessage (LTM.LocalTxMonitor txid tx slotNo)) where + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgAcquire {}) = mconcat [ "kind" .= String "MsgAcquire" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgAcquired {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgAcquired {}) = mconcat [ "kind" .= String "MsgAcquired" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgAwaitAcquire {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgAwaitAcquire {}) = mconcat [ "kind" .= String "MsgAwaitAcquire" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgNextTx {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgNextTx {}) = mconcat [ "kind" .= String "MsgNextTx" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgReplyNextTx {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgReplyNextTx {}) = mconcat [ "kind" .= String "MsgReplyNextTx" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgHasTx {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgHasTx {}) = mconcat [ "kind" .= String "MsgHasTx" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgReplyHasTx {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgReplyHasTx {}) = mconcat [ "kind" .= String "MsgReplyHasTx" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgGetSizes {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgGetSizes {}) = mconcat [ "kind" .= String "MsgGetSizes" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgReplyGetSizes {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgReplyGetSizes {}) = mconcat [ "kind" .= String "MsgReplyGetSizes" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgRelease {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgRelease {}) = mconcat [ "kind" .= String "MsgRelease" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgDone {}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTM.MsgDone {}) = mconcat [ "kind" .= String "MsgDone" , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (LTM.LocalTxMonitor txid tx slotNo)) where - namespaceFor (AnyMessageAndAgency _agency LTM.MsgAcquire {}) = +instance MetaTrace (Simple.AnyMessage (LTM.LocalTxMonitor txid tx slotNo)) where + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgAcquire {}) = Namespace [] ["Acquire"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgAcquired {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgAcquired {}) = Namespace [] ["Acquired"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgAwaitAcquire {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgAwaitAcquire {}) = Namespace [] ["AwaitAcquire"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgNextTx {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgNextTx {}) = Namespace [] ["NextTx"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgReplyNextTx {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgReplyNextTx {}) = Namespace [] ["ReplyNextTx"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgHasTx {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgHasTx {}) = Namespace [] ["HasTx"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgReplyHasTx {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgReplyHasTx {}) = Namespace [] ["ReplyHasTx"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgGetSizes {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgGetSizes {}) = Namespace [] ["GetSizes"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgReplyGetSizes {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgReplyGetSizes {}) = Namespace [] ["ReplyGetSizes"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgRelease {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgRelease {}) = Namespace [] ["Release"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgDone {}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgDone {}) = Namespace [] ["Done"] severityFor (Namespace _ ["Acquire"]) _ = Just Info @@ -344,32 +411,32 @@ instance MetaTrace (AnyMessageAndAgency (LTM.LocalTxMonitor txid tx slotNo)) whe -- LocalTxSubmission Tracer -------------------------------------------------------------------------------- -instance LogFormatting (AnyMessageAndAgency (LTS.LocalTxSubmission tx err)) where - forMachine _dtal (AnyMessageAndAgency stok LTS.MsgSubmitTx{}) = +instance LogFormatting (Simple.AnyMessage (LTS.LocalTxSubmission tx err)) where + forMachine _dtal (Simple.AnyMessageAndAgency stok LTS.MsgSubmitTx{}) = mconcat [ "kind" .= String "MsgSubmitTx" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTS.MsgAcceptTx{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTS.MsgAcceptTx{}) = mconcat [ "kind" .= String "MsgAcceptTx" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTS.MsgRejectTx{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTS.MsgRejectTx{}) = mconcat [ "kind" .= String "MsgRejectTx" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LTS.MsgDone{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LTS.MsgDone{}) = mconcat [ "kind" .= String "MsgDone" , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (LTS.LocalTxSubmission tx err)) where - namespaceFor (AnyMessageAndAgency _agency LTS.MsgSubmitTx{}) = +instance MetaTrace (Simple.AnyMessage (LTS.LocalTxSubmission tx err)) where + namespaceFor (Simple.AnyMessageAndAgency _agency LTS.MsgSubmitTx{}) = Namespace [] ["SubmitTx"] - namespaceFor (AnyMessageAndAgency _agency LTS.MsgAcceptTx{}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTS.MsgAcceptTx{}) = Namespace [] ["AcceptTx"] - namespaceFor (AnyMessageAndAgency _agency LTS.MsgRejectTx{}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTS.MsgRejectTx{}) = Namespace [] ["RejectTx"] - namespaceFor (AnyMessageAndAgency _agency LTS.MsgDone{}) = + namespaceFor (Simple.AnyMessageAndAgency _agency LTS.MsgDone{}) = Namespace [] ["Done"] severityFor (Namespace _ ["SubmitTx"]) _ = Just Info @@ -401,56 +468,170 @@ instance MetaTrace (AnyMessageAndAgency (LTS.LocalTxSubmission tx err)) where -------------------------------------------------------------------------------- instance (forall result. Show (Query blk result)) - => LogFormatting (AnyMessageAndAgency (LSQ.LocalStateQuery blk pt (Query blk))) where - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgAcquire{}) = + => LogFormatting (Simple.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk))) where + forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgAcquire{}) = mconcat [ "kind" .= String "MsgAcquire" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgAcquired{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgAcquired{}) = mconcat [ "kind" .= String "MsgAcquired" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgFailure{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgFailure{}) = mconcat [ "kind" .= String "MsgFailure" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgQuery{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgQuery{}) = mconcat [ "kind" .= String "MsgQuery" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgResult{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgResult{}) = mconcat [ "kind" .= String "MsgResult" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgRelease{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgRelease{}) = mconcat [ "kind" .= String "MsgRelease" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgReAcquire{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgReAcquire{}) = mconcat [ "kind" .= String "MsgReAcquire" , "agency" .= String (pack $ show stok) ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgDone{}) = + forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgDone{}) = mconcat [ "kind" .= String "MsgDone" , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (LSQ.LocalStateQuery blk pt (Query blk))) where - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgAcquire{}) = +instance (forall result. Show (Query blk result)) + => LogFormatting (Stateful.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk)) f) where + forMachine _dtal (Stateful.AnyMessageAndAgency stok _ LSQ.MsgAcquire{}) = + mconcat [ "kind" .= String "MsgAcquire" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Stateful.AnyMessageAndAgency stok _ LSQ.MsgAcquired{}) = + mconcat [ "kind" .= String "MsgAcquired" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Stateful.AnyMessageAndAgency stok _ LSQ.MsgFailure{}) = + mconcat [ "kind" .= String "MsgFailure" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Stateful.AnyMessageAndAgency stok _ LSQ.MsgQuery{}) = + mconcat [ "kind" .= String "MsgQuery" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Stateful.AnyMessageAndAgency stok _ LSQ.MsgResult{}) = + mconcat [ "kind" .= String "MsgResult" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Stateful.AnyMessageAndAgency stok _ LSQ.MsgRelease{}) = + mconcat [ "kind" .= String "MsgRelease" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Stateful.AnyMessageAndAgency stok _ LSQ.MsgReAcquire{}) = + mconcat [ "kind" .= String "MsgReAcquire" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Stateful.AnyMessageAndAgency stok _ LSQ.MsgDone{}) = + mconcat [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + +instance MetaTrace (Simple.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk))) where + namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgAcquire{}) = + Namespace [] ["Acquire"] + namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgAcquired{}) = + Namespace [] ["Acquired"] + namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgFailure{}) = + Namespace [] ["Failure"] + namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgQuery{}) = + Namespace [] ["Query"] + namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgResult{}) = + Namespace [] ["Result"] + namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgRelease{}) = + Namespace [] ["Release"] + namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgReAcquire{}) = + Namespace [] ["ReAcquire"] + namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgDone{}) = + Namespace [] ["Done"] + + severityFor (Namespace _ ["Acquire"]) _ = Just Info + severityFor (Namespace _ ["Acquired"]) _ = Just Info + severityFor (Namespace _ ["Failure"]) _ = Just Warning + severityFor (Namespace _ ["Query"]) _ = Just Info + severityFor (Namespace _ ["Result"]) _ = Just Info + severityFor (Namespace _ ["Release"]) _ = Just Info + severityFor (Namespace _ ["ReAcquire"]) _ = Just Info + severityFor (Namespace _ ["Done"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["Acquire"]) = Just $ mconcat + [ "The client requests that the state as of a particular recent point on " + , "the server's chain (within K of the tip) be made available to query, " + , "and waits for confirmation or failure. " + , "\n " + , "From 'NodeToClient_V8' onwards if the point is not specified, current tip " + , "will be acquired. For previous versions of the protocol 'point' must be " + , "given." + ] + documentFor (Namespace _ ["Acquired"]) = Just + "The server can confirm that it has the state at the requested point." + documentFor (Namespace _ ["Failure"]) = Just $ mconcat + [ "The server can report that it cannot obtain the state for the " + , "requested point." + ] + documentFor (Namespace _ ["Query"]) = Just + "The client can perform queries on the current acquired state." + documentFor (Namespace _ ["Result"]) = Just + "The server must reply with the queries." + documentFor (Namespace _ ["Release"]) = Just $ mconcat + [ "The client can instruct the server to release the state. This lets " + , "the server free resources." + ] + documentFor (Namespace _ ["ReAcquire"]) = Just $ mconcat + [ "This is like 'MsgAcquire' but for when the client already has a " + , "state. By moving to another state directly without a 'MsgRelease' it " + , "enables optimisations on the server side (e.g. moving to the state for " + , "the immediate next block). " + , "\n " + , "Note that failure to re-acquire is equivalent to 'MsgRelease', " + , "rather than keeping the exiting acquired state. " + , "\n " + , "From 'NodeToClient_V8' onwards if the point is not specified, current tip " + , "will be acquired. For previous versions of the protocol 'point' must be " + , "given." + ] + documentFor (Namespace _ ["Done"]) = Just + "The client can terminate the protocol." + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["Acquire"] + , Namespace [] ["Acquired"] + , Namespace [] ["Failure"] + , Namespace [] ["Query"] + , Namespace [] ["Result"] + , Namespace [] ["Release"] + , Namespace [] ["ReAcquire"] + , Namespace [] ["Done"] + ] + +instance MetaTrace (Stateful.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk)) f) where + namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgAcquire{}) = Namespace [] ["Acquire"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgAcquired{}) = + namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgAcquired{}) = Namespace [] ["Acquired"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgFailure{}) = + namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgFailure{}) = Namespace [] ["Failure"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgQuery{}) = + namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgQuery{}) = Namespace [] ["Query"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgResult{}) = + namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgResult{}) = Namespace [] ["Result"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgRelease{}) = + namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgRelease{}) = Namespace [] ["Release"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgReAcquire{}) = + namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgReAcquire{}) = Namespace [] ["ReAcquire"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgDone{}) = + namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgDone{}) = Namespace [] ["Done"] severityFor (Namespace _ ["Acquire"]) _ = Just Info diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs index d8157a26750..4388b1d64b3 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs @@ -22,12 +22,13 @@ import Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints, e import Ouroboros.Network.Block (Point, Serialised (..), blockHash) import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch (..), Message (..)) import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as STX +import qualified Ouroboros.Network.Protocol.KeepAlive.Type as KA import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) import Data.Aeson (ToJSON (..), Value (String), (.=)) import Data.Proxy (Proxy (..)) import Data.Text (pack) -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) +import Network.TypedProtocol.Codec (AnyMessage (AnyMessageAndAgency)) -------------------------------------------------------------------------------- -- BlockFetch Tracer @@ -40,7 +41,7 @@ instance ( ConvertTxId blk , HasTxs blk , LedgerSupportsMempool blk ) - => LogFormatting (AnyMessageAndAgency (BlockFetch blk (Point blk))) where + => LogFormatting (AnyMessage (BlockFetch blk (Point blk))) where forMachine DMinimal (AnyMessageAndAgency stok (MsgBlock blk)) = mconcat [ "kind" .= String "MsgBlock" , "agency" .= String (pack $ show stok) @@ -84,7 +85,7 @@ instance ( ConvertTxId blk instance ToJSON SizeInBytes where toJSON (SizeInBytes s) = toJSON s -instance MetaTrace (AnyMessageAndAgency (BlockFetch blk1 (Point blk2))) where +instance MetaTrace (AnyMessage (BlockFetch blk1 (Point blk2))) where namespaceFor (AnyMessageAndAgency _stok MsgRequestRange{}) = Namespace [] ["RequestRange"] namespaceFor (AnyMessageAndAgency _stok MsgStartBatch{}) = @@ -140,7 +141,7 @@ instance ( ConvertTxId blk , HasTxs blk , HasTxId (GenTx blk) ) - => LogFormatting (AnyMessageAndAgency (BlockFetch (Serialised blk) (Point blk))) where + => LogFormatting (AnyMessage (BlockFetch (Serialised blk) (Point blk))) where forMachine _dtal (AnyMessageAndAgency stok (MsgBlock blk')) = mconcat [ "kind" .= String "MsgBlock" , "agency" .= String (pack $ show stok) @@ -175,7 +176,7 @@ instance ( ConvertTxId blk -------------------------------------------------------------------------------- instance (Show txid, Show tx) - => LogFormatting (AnyMessageAndAgency (STX.TxSubmission2 txid tx)) where + => LogFormatting (AnyMessage (STX.TxSubmission2 txid tx)) where forMachine _dtal (AnyMessageAndAgency stok STX.MsgInit) = mconcat [ "kind" .= String "MsgInit" @@ -209,7 +210,7 @@ instance (Show txid, Show tx) , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (STX.TxSubmission2 txid tx)) where +instance MetaTrace (AnyMessage (STX.TxSubmission2 txid tx)) where namespaceFor (AnyMessageAndAgency _stok STX.MsgInit {}) = Namespace [] ["MsgInit"] namespaceFor (AnyMessageAndAgency _stok STX.MsgRequestTxs {}) = @@ -328,3 +329,53 @@ instance MetaTrace (AnyMessageAndAgency (STX.TxSubmission2 txid tx)) where , Namespace [] ["ReplyTxs"] , Namespace [] ["Done"] ] + +-------------------------------------------------------------------------------- +-- KeepAlive Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting (AnyMessage KA.KeepAlive) where + forMachine _dtal (AnyMessageAndAgency stok KA.MsgKeepAlive {}) = + mconcat + [ "kind" .= String "KeepAlive" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok KA.MsgKeepAliveResponse {}) = + mconcat + [ "kind" .= String "KeepAliveResponse" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok KA.MsgDone) = + mconcat + [ "kind" .= String "Done" + , "agency" .= String (pack $ show stok) + ] + +instance MetaTrace (AnyMessage KA.KeepAlive) where + namespaceFor (AnyMessageAndAgency _stok KA.MsgKeepAlive {}) = + Namespace [] ["KeepAlive"] + namespaceFor (AnyMessageAndAgency _stok KA.MsgKeepAliveResponse {}) = + Namespace [] ["KeepAliveResponse"] + namespaceFor (AnyMessageAndAgency _stok KA.MsgDone) = + Namespace [] ["Done"] + + severityFor (Namespace _ ["KeepAlive"]) _ = Just Info + severityFor (Namespace _ ["KeepAliveResponse"]) _ = Just Info + severityFor (Namespace _ ["Done"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["KeepAlive"]) = Just + "Client side message to keep the connection alive." + documentFor (Namespace _ ["KeepAliveResponse"]) = Just $ mconcat + [ "Server side response to a previous client KeepAlive message." + ] + documentFor (Namespace _ ["Done"]) = Just $ mconcat + [ "Termination message, initiated by the client." + ] + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["KeepAlive"] + , Namespace [] ["KeepAliveResponse"] + , Namespace [] ["Done"] + ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs index aa36f94107f..7a548bbb2f4 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs @@ -26,12 +26,13 @@ import Cardano.Node.Tracing.Tracers.NonP2P () import Cardano.Tracing.OrphanInstances.Network () import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) import Ouroboros.Network.ConnectionId (ConnectionId (..)) -import Ouroboros.Network.ConnectionManager.Types (ConnectionManagerCounters (..), - ConnectionManagerTrace (..)) +import Ouroboros.Network.ConnectionManager.Core as ConnectionManager (Trace (..)) +import Ouroboros.Network.ConnectionManager.Types (ConnectionManagerCounters (..)) +import Ouroboros.Network.ConnectionManager.ConnMap (ConnMap (..)) import qualified Ouroboros.Network.ConnectionManager.Types as ConnectionManager -import Ouroboros.Network.InboundGovernor (InboundGovernorTrace (..)) +import Ouroboros.Network.InboundGovernor as InboundGovernor (Trace (..)) import qualified Ouroboros.Network.InboundGovernor as InboundGovernor -import Ouroboros.Network.InboundGovernor.State (InboundGovernorCounters (..)) +import Ouroboros.Network.InboundGovernor.State as InboundGovernor (Counters (..)) import qualified Ouroboros.Network.NodeToNode as NtN import Ouroboros.Network.PeerSelection.Governor (ChurnCounters (..), DebugPeerSelection (..), DebugPeerSelectionState (..), PeerSelectionCounters, @@ -47,9 +48,10 @@ import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import Ouroboros.Network.PeerSelection.Types () import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..)) import Ouroboros.Network.RethrowPolicy (ErrorCommand (..)) -import Ouroboros.Network.Server2 (ServerTrace (..)) +import Ouroboros.Network.Server2 as Server import Ouroboros.Network.Snocket (LocalAddress (..)) +import Control.Exception (displayException) import Data.Aeson (Object, ToJSON, ToJSONKey, Value (..), object, toJSON, toJSONList, (.=)) import Data.Aeson.Types (listValue) @@ -515,6 +517,9 @@ instance LogFormatting (TracePeerSelection SockAddr) where forMachine _dtal TraceBootstrapPeersFlagChangedWhilstInSensitiveState = mconcat [ "kind" .= String "BootstrapPeersFlagChangedWhilstInSensitiveState" ] + forMachine _dtal (TraceVerifyPeerSnapshot result) = + mconcat [ "kind" .= String "VerifyPeerSnapshot" + , "result" .= toJSON result ] forMachine _dtal (TraceOutboundGovernorCriticalFailure err) = mconcat [ "kind" .= String "OutboundGovernorCriticalFailure" , "reason" .= show err @@ -668,6 +673,8 @@ instance MetaTrace (TracePeerSelection SockAddr) where Namespace [] ["OnlyBootstrapPeers"] namespaceFor TraceUseBootstrapPeersChanged {} = Namespace [] ["UseBootstrapPeersChanged"] + namespaceFor TraceVerifyPeerSnapshot {} = + Namespace [] ["VerifyPeerSnapshot"] namespaceFor TraceBootstrapPeersFlagChangedWhilstInSensitiveState = Namespace [] ["BootstrapPeersFlagChangedWhilstInSensitiveState"] namespaceFor TraceOutboundGovernorCriticalFailure {} = @@ -713,6 +720,7 @@ instance MetaTrace (TracePeerSelection SockAddr) where severityFor (Namespace [] ["ChurnAction"]) _ = Just Info severityFor (Namespace [] ["ChurnTimeout"]) _ = Just Notice severityFor (Namespace [] ["DebugState"]) _ = Just Info + severityFor (Namespace [] ["VerifyPeerSnapshot"]) _ = Just Error severityFor _ _ = Nothing documentFor (Namespace [] ["LocalRootPeersChanged"]) = Just "" @@ -771,6 +779,8 @@ instance MetaTrace (TracePeerSelection SockAddr) where "Outbound Governor was killed unexpectedly" documentFor (Namespace [] ["DebugState"]) = Just "peer selection internal state" + documentFor (Namespace [] ["VerifyPeerSnapshot"]) = Just + "Verification outcome of big ledger peer snapshot" documentFor _ = Nothing metricsDocFor (Namespace [] ["ChurnAction"]) = @@ -816,6 +826,7 @@ instance MetaTrace (TracePeerSelection SockAddr) where , Namespace [] ["PickInboundPeers"] , Namespace [] ["OutboundGovernorCriticalFailure"] , Namespace [] ["DebugState"] + , Namespace [] ["VerifyPeerSnapshot"] ] -------------------------------------------------------------------------------- @@ -1137,6 +1148,10 @@ instance Show lAddr => LogFormatting (PeerSelectionActionsTrace SockAddr lAddr) , "connectionId" .= toJSON connId , "withProtocolTemp" .= show wf ] + forMachine _dtal (AcquireConnectionError exception) = + mconcat [ "kind" .= String "AcquireConnectionError" + , "error" .= displayException exception + ] forHuman = pack . show instance MetaTrace (PeerSelectionActionsTrace SockAddr lAddr) where @@ -1144,11 +1159,13 @@ instance MetaTrace (PeerSelectionActionsTrace SockAddr lAddr) where namespaceFor PeerStatusChangeFailure {} = Namespace [] ["StatusChangeFailure"] namespaceFor PeerMonitoringError {} = Namespace [] ["MonitoringError"] namespaceFor PeerMonitoringResult {} = Namespace [] ["MonitoringResult"] + namespaceFor AcquireConnectionError {} = Namespace [] ["ConnectionError"] severityFor (Namespace _ ["StatusChanged"]) _ = Just Info severityFor (Namespace _ ["StatusChangeFailure"]) _ = Just Error severityFor (Namespace _ ["MonitoringError"]) _ = Just Error severityFor (Namespace _ ["MonitoringResult"]) _ = Just Debug + severityFor (Namespace _ ["ConnectionError"]) _ = Just Error severityFor _ _ = Nothing documentFor (Namespace _ ["StatusChanged"]) = Just @@ -1159,6 +1176,8 @@ instance MetaTrace (PeerSelectionActionsTrace SockAddr lAddr) where "" documentFor (Namespace _ ["MonitoringResult"]) = Just "" + documentFor (Namespace _ ["ConnectionError"]) = Just + "" documentFor _ = Nothing allNamespaces = [ @@ -1166,6 +1185,7 @@ instance MetaTrace (PeerSelectionActionsTrace SockAddr lAddr) where , Namespace [] ["StatusChangeFailure"] , Namespace [] ["MonitoringError"] , Namespace [] ["MonitoringResult"] + , Namespace [] ["ConnectionError"] ] -------------------------------------------------------------------------------- @@ -1174,28 +1194,30 @@ instance MetaTrace (PeerSelectionActionsTrace SockAddr lAddr) where instance (Show addr, Show versionNumber, Show agreedOptions, LogFormatting addr, ToJSON addr, ToJSON versionNumber, ToJSON agreedOptions) - => LogFormatting (ConnectionManagerTrace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where + => LogFormatting (ConnectionManager.Trace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where forMachine dtal (TrIncludeConnection prov peerAddr) = mconcat $ reverse [ "kind" .= String "IncludeConnection" , "remoteAddress" .= forMachine dtal peerAddr , "provenance" .= String (pack . show $ prov) ] - forMachine dtal (TrUnregisterConnection prov peerAddr) = + forMachine _dtal (TrReleaseConnection prov connId) = mconcat $ reverse [ "kind" .= String "UnregisterConnection" - , "remoteAddress" .= forMachine dtal peerAddr + , "remoteAddress" .= toJSON connId , "provenance" .= String (pack . show $ prov) ] - forMachine _dtal (TrConnect (Just localAddress) remoteAddress) = + forMachine _dtal (TrConnect (Just localAddress) remoteAddress diffusionMode) = mconcat - [ "kind" .= String "ConnectTo" + [ "kind" .= String "Connect" , "connectionId" .= toJSON ConnectionId { localAddress, remoteAddress } + , "diffusionMode" .= toJSON diffusionMode ] - forMachine dtal (TrConnect Nothing remoteAddress) = + forMachine dtal (TrConnect Nothing remoteAddress diffusionMode) = mconcat - [ "kind" .= String "ConnectTo" + [ "kind" .= String "Connect" , "remoteAddress" .= forMachine dtal remoteAddress + , "diffusionMode" .= toJSON diffusionMode ] forMachine _dtal (TrConnectError (Just localAddress) remoteAddress err) = mconcat @@ -1260,12 +1282,12 @@ instance (Show addr, Show versionNumber, Show agreedOptions, LogFormatting addr, , "remoteAddress" .= forMachine dtal remoteAddress , "connectionState" .= toJSON connState ] - forMachine dtal (TrPruneConnections pruningSet numberPruned chosenPeers) = + forMachine _dtal (TrPruneConnections pruningSet numberPruned chosenPeers) = mconcat [ "kind" .= String "PruneConnections" , "prunedPeers" .= toJSON pruningSet , "numberPrunedPeers" .= toJSON numberPruned - , "choiceSet" .= toJSON (forMachine dtal `Set.map` chosenPeers) + , "choiceSet" .= toJSON (toJSON `Set.map` chosenPeers) ] forMachine _dtal (TrConnectionCleanup connId) = mconcat @@ -1290,12 +1312,20 @@ instance (Show addr, Show versionNumber, Show agreedOptions, LogFormatting addr, forMachine _dtal (TrState cmState) = mconcat [ "kind" .= String "ConnectionManagerState" - , "state" .= listValue (\(addr, connState) -> + , "state" .= listValue (\(remoteAddr, inner) -> object - [ "remoteAddress" .= toJSON addr - , "connectionState" .= toJSON connState - ]) - (Map.toList cmState) + [ "connections" .= + listValue (\(localAddr, connState) -> + object + [ "localAddress" .= localAddr + , "state" .= toJSON connState + ] + ) + (Map.toList inner) + , "remoteAddress" .= toJSON remoteAddr + ] + ) + (Map.toList (getConnMap cmState)) ] forMachine _dtal (ConnectionManager.TrUnexpectedlyFalseAssertion info) = mconcat @@ -1356,10 +1386,10 @@ instance (Show versionNumber, ToJSON versionNumber, ToJSON agreedOptions) , "command" .= show cerr ] -instance MetaTrace (ConnectionManagerTrace addr +instance MetaTrace (ConnectionManager.Trace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where namespaceFor TrIncludeConnection {} = Namespace [] ["IncludeConnection"] - namespaceFor TrUnregisterConnection {} = Namespace [] ["UnregisterConnection"] + namespaceFor TrReleaseConnection {} = Namespace [] ["UnregisterConnection"] namespaceFor TrConnect {} = Namespace [] ["Connect"] namespaceFor TrConnectError {} = Namespace [] ["ConnectError"] namespaceFor TrTerminatingConnection {} = Namespace [] ["TerminatingConnection"] @@ -1501,10 +1531,10 @@ instance MetaTrace (ConnectionManager.AbstractTransitionTrace peerAddr) where -------------------------------------------------------------------------------- instance (Show addr, LogFormatting addr, ToJSON addr) - => LogFormatting (ServerTrace addr) where - forMachine dtal (TrAcceptConnection peerAddr) = + => LogFormatting (Server.Trace addr) where + forMachine _dtal (TrAcceptConnection connId) = mconcat [ "kind" .= String "AcceptConnection" - , "address" .= forMachine dtal peerAddr + , "address" .= toJSON connId ] forMachine _dtal (TrAcceptError exception) = mconcat [ "kind" .= String "AcceptErroor" @@ -1527,7 +1557,7 @@ instance (Show addr, LogFormatting addr, ToJSON addr) ] forHuman = pack . show -instance MetaTrace (ServerTrace addr) where +instance MetaTrace (Server.Trace addr) where namespaceFor TrAcceptConnection {} = Namespace [] ["AcceptConnection"] namespaceFor TrAcceptError {} = Namespace [] ["AcceptError"] namespaceFor TrAcceptPolicyTrace {} = Namespace [] ["AcceptPolicy"] @@ -1564,10 +1594,10 @@ instance MetaTrace (ServerTrace addr) where -- InboundGovernor Tracer -------------------------------------------------------------------------------- -instance LogFormatting (InboundGovernorTrace SockAddr) where +instance LogFormatting (InboundGovernor.Trace SockAddr) where forMachine = forMachineGov forHuman = pack . show - asMetrics (TrInboundGovernorCounters InboundGovernorCounters {..}) = + asMetrics (TrInboundGovernorCounters InboundGovernor.Counters {..}) = [ IntM "inboundGovernor.idle" (fromIntegral idlePeersRemote) @@ -1583,10 +1613,10 @@ instance LogFormatting (InboundGovernorTrace SockAddr) where ] asMetrics _ = [] -instance LogFormatting (InboundGovernorTrace LocalAddress) where +instance LogFormatting (InboundGovernor.Trace LocalAddress) where forMachine = forMachineGov forHuman = pack . show - asMetrics (TrInboundGovernorCounters InboundGovernorCounters {..}) = + asMetrics (TrInboundGovernorCounters InboundGovernor.Counters {..}) = [ IntM "localInboundGovernor.idle" (fromIntegral idlePeersRemote) @@ -1603,7 +1633,7 @@ instance LogFormatting (InboundGovernorTrace LocalAddress) where asMetrics _ = [] -forMachineGov :: (ToJSON adr, Show adr) => DetailLevel -> InboundGovernorTrace adr -> Object +forMachineGov :: (ToJSON adr, Show adr) => DetailLevel -> InboundGovernor.Trace adr -> Object forMachineGov _dtal (TrNewConnection p connId) = mconcat [ "kind" .= String "NewConnection" , "provenance" .= show p @@ -1697,7 +1727,7 @@ forMachineGov _dtal (InboundGovernor.TrInactive fresh) = , "fresh" .= toJSON fresh ] -instance MetaTrace (InboundGovernorTrace addr) where +instance MetaTrace (InboundGovernor.Trace addr) where namespaceFor TrNewConnection {} = Namespace [] ["NewConnection"] namespaceFor TrResponderRestarted {} = Namespace [] ["ResponderRestarted"] namespaceFor TrResponderStartFailure {} = Namespace [] ["ResponderStartFailure"] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs index 0175ead4890..0c7964cc834 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs @@ -15,8 +15,7 @@ import Cardano.Node.Orphans () import Cardano.Node.Queries import Ouroboros.Consensus.Block (Header) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientHandle, - csCandidate, viewChainSyncState) -import Ouroboros.Consensus.Util.NormalForm.StrictTVar (StrictTVar) + csCandidate, cschcMap, viewChainSyncState, ) import Ouroboros.Consensus.Util.Orphans () import qualified Ouroboros.Network.AnchoredFragment as Net import Ouroboros.Network.Block (unSlotNo) @@ -104,7 +103,7 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd tuple3pop (a, b, _) = (a, b) getCandidates - :: StrictTVar IO (Map peer (ChainSyncClientHandle IO blk)) + :: STM.STM IO (Map peer (ChainSyncClientHandle IO blk)) -> STM.STM IO (Map peer (Net.AnchoredFragment (Header blk))) getCandidates handle = viewChainSyncState handle csCandidate @@ -116,7 +115,7 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd . Net.readFetchClientsStateVars . getFetchClientRegistry $ kernel ) - candidates <- STM.atomically . getCandidates . getChainSyncHandles $ kernel + candidates <- STM.atomically . getCandidates . cschcMap . getChainSyncHandles $ kernel let peers = flip Map.mapMaybeWithKey candidates $ \cid af -> maybe Nothing diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs index 65e82a1d844..7ef202a6b3c 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs @@ -26,6 +26,7 @@ import Cardano.Node.Configuration.POM (NodeConfiguration, ncProtocol) import Cardano.Node.Configuration.Socket import Cardano.Node.Protocol (SomeConsensusProtocol (..)) import Cardano.Node.Startup +import Cardano.Node.Types (PeerSnapshotFile (..)) import Cardano.Slotting.Slot (EpochSize (..)) import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as WCT import Ouroboros.Consensus.Byron.Ledger.Conversions (fromByronEpochSlots, @@ -215,17 +216,24 @@ instance ( Show (BlockNodeToNodeVersion blk) forMachine _dtal NetworkConfigUpdate = mconcat [ "kind" .= String "NetworkConfigUpdate" , "message" .= String "network configuration update" ] + forMachine _dtal (LedgerPeerSnapshotLoaded wOrigin) = + mconcat [ "kind" .= String "LedgerPeerSnapshotLoaded" + , "message" .= String (showT wOrigin)] forMachine _dtal NetworkConfigUpdateUnsupported = mconcat [ "kind" .= String "NetworkConfigUpdate" , "message" .= String "network topology reconfiguration is not supported in non-p2p mode" ] forMachine _dtal (NetworkConfigUpdateError err) = mconcat [ "kind" .= String "NetworkConfigUpdateError" , "error" .= String err ] - forMachine _dtal (NetworkConfig localRoots publicRoots useLedgerPeers) = + forMachine _dtal (NetworkConfig localRoots publicRoots useLedgerPeers peerSnapshotFileMaybe) = mconcat [ "kind" .= String "NetworkConfig" , "localRoots" .= toJSON localRoots , "publicRoots" .= toJSON publicRoots , "useLedgerAfter" .= useLedgerPeers + , "peerSnapshotFile" .= + case peerSnapshotFileMaybe of + Nothing -> Null + Just (PeerSnapshotFile path) -> String (pack path) ] forMachine _dtal NonP2PWarning = mconcat [ "kind" .= String "NonP2PWarning" @@ -305,6 +313,8 @@ instance MetaTrace (StartupTrace blk) where Namespace [] ["BlockForgingBlockTypeMismatch"] namespaceFor NetworkConfigUpdate {} = Namespace [] ["NetworkConfigUpdate"] + namespaceFor LedgerPeerSnapshotLoaded {} = + Namespace [] ["LedgerPeerSnapshotLoaded"] namespaceFor NetworkConfigUpdateUnsupported {} = Namespace [] ["NetworkConfigUpdateUnsupported"] namespaceFor NetworkConfigUpdateError {} = @@ -433,16 +443,10 @@ instance MetaTrace (StartupTrace blk) where nodeToClientVersionToInt :: NodeToClientVersion -> Int nodeToClientVersionToInt = \case - NodeToClientV_9 -> 9 - NodeToClientV_10 -> 10 - NodeToClientV_11 -> 11 - NodeToClientV_12 -> 12 - NodeToClientV_13 -> 13 - NodeToClientV_14 -> 14 - NodeToClientV_15 -> 15 NodeToClientV_16 -> 16 NodeToClientV_17 -> 17 NodeToClientV_18 -> 18 + NodeToClientV_19 -> 19 nodeToNodeVersionToInt :: NodeToNodeVersion -> Int nodeToNodeVersionToInt = \case @@ -512,7 +516,7 @@ ppStartupInfoTrace NetworkConfigUpdate = "Performing topology configuration upda ppStartupInfoTrace NetworkConfigUpdateUnsupported = "Network topology reconfiguration is not supported in non-p2p mode" ppStartupInfoTrace (NetworkConfigUpdateError err) = err -ppStartupInfoTrace (NetworkConfig localRoots publicRoots useLedgerPeers) = +ppStartupInfoTrace (NetworkConfig localRoots publicRoots useLedgerPeers peerSnapshotFile) = pack $ intercalate "\n" [ "\nLocal Root Groups:" @@ -528,8 +532,15 @@ ppStartupInfoTrace (NetworkConfig localRoots publicRoots useLedgerPeers) = ++ show (unSlotNo slotNo) UseLedgerPeers Always -> "Use ledger peers in any slot." + , case peerSnapshotFile of + Nothing -> "Topology configuration does not specify ledger peer snapshot file" + Just p -> "Topology configuration specifies ledger peer snapshot file: " + <> show (unPeerSnapshotFile p) ] +ppStartupInfoTrace (LedgerPeerSnapshotLoaded wOrigin) = + "Topology: Peer snapshot containing ledger peers " <> showT wOrigin <> " loaded." + ppStartupInfoTrace NonP2PWarning = nonP2PWarningMessage ppStartupInfoTrace (WarningDevelopmentNodeToNodeVersions ntnVersions) = diff --git a/cardano-node/src/Cardano/Node/Types.hs b/cardano-node/src/Cardano/Node/Types.hs index 87cc9c72685..174d6d2f0db 100644 --- a/cardano-node/src/Cardano/Node/Types.hs +++ b/cardano-node/src/Cardano/Node/Types.hs @@ -14,12 +14,14 @@ module Cardano.Node.Types , ConfigYamlFilePath(..) , DbFile(..) , GenesisFile(..) + , PeerSnapshotFile (..) , ProtocolFilepaths (..) , GenesisHash(..) , MaxConcurrencyBulkSync(..) , MaxConcurrencyDeadline(..) -- * Networking , TopologyFile(..) + , NodeConsensusMode (..) , NodeDiffusionMode (..) -- * Consensus protocol configuration , NodeByronProtocolConfiguration(..) @@ -38,6 +40,7 @@ import Cardano.Api import Cardano.Crypto (RequiresNetworkMagic (..)) import qualified Cardano.Crypto.Hash as Crypto import Cardano.Node.Configuration.Socket (SocketConfig (..)) +import Ouroboros.Network.ConsensusMode (ConsensusMode (..)) import Ouroboros.Network.NodeToNode (DiffusionMode (..)) import Control.Exception @@ -80,6 +83,14 @@ newtype GenesisFile = GenesisFile deriving stock (Eq, Ord) deriving newtype (IsString, Show) +-- | Path containing a serialized ledger peer snapshot +-- for use by diffusion layer to facilitate bootstrapping +-- a node in Genesis consensus mode +-- +newtype PeerSnapshotFile = PeerSnapshotFile { unPeerSnapshotFile :: FilePath } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + instance FromJSON GenesisFile where parseJSON (String genFp) = pure . GenesisFile $ Text.unpack genFp parseJSON invalid = fail $ "Parsing of GenesisFile failed due to type mismatch. " @@ -96,11 +107,34 @@ newtype MaxConcurrencyDeadline = MaxConcurrencyDeadline deriving newtype (FromJSON, Show) --- | Newtype wrapper which provides 'FromJSON' instance for 'DiffusionMode'. +-- | Newtype wrapper which provides 'FromJSON' instance for 'ConsensusMode'. +-- +newtype NodeConsensusMode + = NodeConsensusMode { getConsensusMode :: ConsensusMode } + deriving newtype Show + +instance FromJSON NodeConsensusMode where + parseJSON (String str) = + case str of + "Genesis" + -> pure $ NodeConsensusMode GenesisMode + "Praos" + -> pure $ NodeConsensusMode PraosMode + _ -> fail "Parsing NodeConsensusMode failed: can be either 'Genesis' or 'Praos'" + parseJSON _ = fail "Parsing NodeConsensusMode failed" + +-- | Newtype wrapper which provides 'ToJSON' and 'FromJSON' instances for +-- 'DiffusionMode'. -- newtype NodeDiffusionMode = NodeDiffusionMode { getDiffusionMode :: DiffusionMode } - deriving newtype Show + deriving newtype (Eq, Show) + +instance ToJSON NodeDiffusionMode where + toJSON (NodeDiffusionMode InitiatorOnlyDiffusionMode) + = String "InitiatorOnly" + toJSON (NodeDiffusionMode InitiatorAndResponderDiffusionMode) + = String "InitiatorAndResponder" instance FromJSON NodeDiffusionMode where parseJSON (String str) = diff --git a/cardano-node/src/Cardano/Tracing/Config.hs b/cardano-node/src/Cardano/Tracing/Config.hs index 2dd739efd0e..b50a3543416 100644 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ b/cardano-node/src/Cardano/Tracing/Config.hs @@ -70,6 +70,7 @@ module Cardano.Tracing.Config , TraceTxOutbound , TraceTxSubmissionProtocol , TraceTxSubmission2Protocol + , TraceKeepAliveProtocol , proxyName ) where @@ -175,7 +176,9 @@ type TraceTxInbound = ("TraceTxInbound" :: Symbol) type TraceTxOutbound = ("TraceTxOutbound" :: Symbol) type TraceTxSubmissionProtocol = ("TraceTxSubmissionProtocol" :: Symbol) type TraceTxSubmission2Protocol = ("TraceTxSubmission2Protocol" :: Symbol) +type TraceKeepAliveProtocol = ("TraceKeepAliveProtocol" :: Symbol) type TraceGsm = ("TraceGsm" :: Symbol) +type TraceCsj = ("TraceCsj" :: Symbol) newtype OnOff (name :: Symbol) = OnOff { isOn :: Bool } deriving (Eq, Show) @@ -246,7 +249,9 @@ data TraceSelection , traceTxOutbound :: OnOff TraceTxOutbound , traceTxSubmissionProtocol :: OnOff TraceTxSubmissionProtocol , traceTxSubmission2Protocol :: OnOff TraceTxSubmission2Protocol + , traceKeepAliveProtocol :: OnOff TraceKeepAliveProtocol , traceGsm :: OnOff TraceGsm + , traceCsj :: OnOff TraceCsj } deriving (Eq, Show) @@ -311,7 +316,9 @@ data PartialTraceSelection , pTraceTxOutbound :: Last (OnOff TraceTxOutbound) , pTraceTxSubmissionProtocol :: Last (OnOff TraceTxSubmissionProtocol) , pTraceTxSubmission2Protocol :: Last (OnOff TraceTxSubmission2Protocol) + , pTraceKeepAliveProtocol :: Last (OnOff TraceKeepAliveProtocol) , pTraceGsm :: Last (OnOff TraceGsm) + , pTraceCsj :: Last (OnOff TraceCsj) } deriving (Eq, Generic, Show) @@ -377,7 +384,9 @@ instance FromJSON PartialTraceSelection where <*> parseTracer (Proxy @TraceTxOutbound) v <*> parseTracer (Proxy @TraceTxSubmissionProtocol) v <*> parseTracer (Proxy @TraceTxSubmission2Protocol) v + <*> parseTracer (Proxy @TraceKeepAliveProtocol) v <*> parseTracer (Proxy @TraceGsm) v + <*> parseTracer (Proxy @TraceCsj) v defaultPartialTraceConfiguration :: PartialTraceSelection @@ -440,7 +449,9 @@ defaultPartialTraceConfiguration = , pTraceTxOutbound = pure $ OnOff False , pTraceTxSubmissionProtocol = pure $ OnOff False , pTraceTxSubmission2Protocol = pure $ OnOff False + , pTraceKeepAliveProtocol = pure $ OnOff False , pTraceGsm = pure $ OnOff True + , pTraceCsj = pure $ OnOff True } @@ -505,7 +516,9 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio traceTxOutbound <- proxyLastToEither (Proxy @TraceTxOutbound) pTraceTxOutbound traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol + traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm + traceCsj <- proxyLastToEither (Proxy @TraceCsj) pTraceCsj Right $ TraceDispatcher $ TraceSelection { traceVerbosity = traceVerbosity , traceAcceptPolicy = traceAcceptPolicy @@ -563,7 +576,9 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio , traceTxOutbound = traceTxOutbound , traceTxSubmissionProtocol = traceTxSubmissionProtocol , traceTxSubmission2Protocol = traceTxSubmission2Protocol + , traceKeepAliveProtocol = traceKeepAliveProtocol , traceGsm = traceGsm + , traceCsj = traceCsj } partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelection))) = do @@ -625,7 +640,9 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio traceTxOutbound <- proxyLastToEither (Proxy @TraceTxOutbound) pTraceTxOutbound traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol + traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm + traceCsj <- proxyLastToEither (Proxy @TraceCsj) pTraceCsj Right $ TracingOnLegacy $ TraceSelection { traceVerbosity = traceVerbosity , traceAcceptPolicy = traceAcceptPolicy @@ -683,7 +700,9 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio , traceTxOutbound = traceTxOutbound , traceTxSubmissionProtocol = traceTxSubmissionProtocol , traceTxSubmission2Protocol = traceTxSubmission2Protocol + , traceKeepAliveProtocol = traceKeepAliveProtocol , traceGsm = traceGsm + , traceCsj = traceCsj } proxyLastToEither :: KnownSymbol name => Proxy name -> Last (OnOff name) -> Either Text (OnOff name) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs index c685dc7b9b1..781a7da684f 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs @@ -26,12 +26,12 @@ import Cardano.Slotting.Slot (fromWithOrigin) import Cardano.Tracing.OrphanInstances.Common import Cardano.Tracing.OrphanInstances.Network () import Cardano.Tracing.Render (renderChainHash, renderChunkNo, renderHeaderHash, - renderHeaderHashForVerbosity, renderPoint, renderPointAsPhrase, + renderHeaderHashForVerbosity, renderPointAsPhrase, renderPointForVerbosity, renderRealPoint, renderRealPointAsPhrase, renderTipBlockNo, renderTipHash, renderWithOrigin) import Ouroboros.Consensus.Block (BlockProtocol, BlockSupportsProtocol, CannotForge, ConvertRawHash (..), ForgeStateUpdateError, GenesisWindow (..), GetHeader (..), - Header, RealPoint, blockNo, blockPoint, blockPrevHash, getHeader, headerPoint, + Header, RealPoint, blockNo, blockPoint, blockPrevHash, getHeader, pointHash, realPointHash, realPointSlot, withOriginToMaybe) import Ouroboros.Consensus.Block.SupportsSanityCheck import Ouroboros.Consensus.Genesis.Governor (DensityBounds (..), GDDDebugInfo (..), @@ -79,6 +79,7 @@ import Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), SlotNo import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..)) import Ouroboros.Network.Point (withOrigin) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import Network.TypedProtocol.Core import Control.Monad (guard) import Data.Aeson (Value (..)) @@ -145,7 +146,6 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.IgnoreInvalidBlock {} -> Info ChainDB.AddedBlockToQueue {} -> Debug ChainDB.PoppedBlockFromQueue {} -> Debug - ChainDB.BlockInTheFuture {} -> Info ChainDB.AddedBlockToVolatileDB {} -> Debug ChainDB.TryAddToCurrentChain {} -> Debug ChainDB.TrySwitchToAFork {} -> Info @@ -158,10 +158,7 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.AddBlockValidation ev' -> case ev' of ChainDB.InvalidBlock {} -> Error ChainDB.ValidCandidate {} -> Info - ChainDB.CandidateContainsFutureBlocks{} -> Debug - ChainDB.CandidateContainsFutureBlocksExceedingClockSkew{} -> Error ChainDB.UpdateLedgerDbTraceEvent {} -> Debug - ChainDB.ChainSelectionForFutureBlock{} -> Debug ChainDB.PipeliningEvent {} -> Debug ChainDB.AddedReprocessLoEBlocksToQueue -> Debug ChainDB.PoppedReprocessLoEBlocksFromQueue -> Debug @@ -177,6 +174,7 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where LedgerDB.TookSnapshot {} -> Info LedgerDB.DeletedSnapshot {} -> Debug LedgerDB.InvalidSnapshot {} -> Error + LedgerDB.SnapshotMissingChecksum {} -> Warning getSeverityAnnotation (ChainDB.TraceCopyToImmutableDBEvent ev) = case ev of ChainDB.CopiedBlockToImmutableDB {} -> Debug @@ -208,8 +206,6 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.InitChainSelValidation ev' -> case ev' of ChainDB.InvalidBlock{} -> Debug ChainDB.ValidCandidate {} -> Info - ChainDB.CandidateContainsFutureBlocks {} -> Debug - ChainDB.CandidateContainsFutureBlocksExceedingClockSkew {} -> Debug ChainDB.UpdateLedgerDbTraceEvent {} -> Info getSeverityAnnotation (ChainDB.TraceIteratorEvent ev) = case ev of @@ -243,6 +239,8 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where VolDb.DBClosed{} -> Info getSeverityAnnotation ChainDB.TraceLastShutdownUnclean = Warning + getSeverityAnnotation ChainDB.TraceChainSelStarvationEvent{} = Debug + instance HasSeverityAnnotation (LedgerEvent blk) where getSeverityAnnotation (LedgerUpdate _) = Notice getSeverityAnnotation (LedgerWarning _) = Critical @@ -273,6 +271,7 @@ instance HasSeverityAnnotation (TraceChainSyncClientEvent blk) where getSeverityAnnotation (TraceJumpResult _) = Debug getSeverityAnnotation TraceJumpingWaitingForNextInstruction = Debug getSeverityAnnotation (TraceJumpingInstructionIs _) = Debug + getSeverityAnnotation (TraceDrainingThePipe _) = Debug instance HasPrivacyAnnotation (TraceChainSyncServerEvent blk) @@ -538,8 +537,6 @@ instance ( ConvertRawHash blk "Popping block from queue" FallingEdgeWith pt -> "Popped block from queue: " <> renderRealPointAsPhrase pt - ChainDB.BlockInTheFuture pt slot -> - "Ignoring block from future: " <> renderRealPointAsPhrase pt <> ", slot " <> condenseT slot ChainDB.StoreButDontChange pt -> "Ignoring block: " <> renderRealPointAsPhrase pt ChainDB.TryAddToCurrentChain pt -> @@ -559,14 +556,6 @@ instance ( ConvertRawHash blk "Invalid block " <> renderRealPointAsPhrase pt <> ": " <> showT err ChainDB.ValidCandidate c -> "Valid candidate " <> renderPointAsPhrase (AF.headPoint c) - ChainDB.CandidateContainsFutureBlocks c hdrs -> - "Candidate contains blocks from near future: " <> - renderPointAsPhrase (AF.headPoint c) <> ", slots " <> - Text.intercalate ", " (map (renderPoint . headerPoint) hdrs) - ChainDB.CandidateContainsFutureBlocksExceedingClockSkew c hdrs -> - "Candidate contains blocks from future exceeding clock skew limit: " <> - renderPointAsPhrase (AF.headPoint c) <> ", slots " <> - Text.intercalate ", " (map (renderPoint . headerPoint) hdrs) ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> let fromSlot = unSlotNo $ realPointSlot start atSlot = unSlotNo $ realPointSlot curr @@ -579,8 +568,6 @@ instance ( ConvertRawHash blk ChainDB.AddedBlockToVolatileDB pt _ _ enclosing -> case enclosing of RisingEdge -> "Chain about to add block " <> renderRealPointAsPhrase pt FallingEdge -> "Chain added block " <> renderRealPointAsPhrase pt - ChainDB.ChainSelectionForFutureBlock pt -> - "Chain selection run for block previously from future: " <> renderRealPointAsPhrase pt ChainDB.PipeliningEvent ev' -> case ev' of ChainDB.SetTentativeHeader hdr enclosing -> case enclosing of RisingEdge -> "About to set tentative header to " <> renderPointAsPhrase (blockPoint hdr) @@ -617,6 +604,8 @@ instance ( ConvertRawHash blk " This is most likely an expected change in the serialization format," <> " which currently requires a chain replay" _ -> "" + LedgerDB.SnapshotMissingChecksum snap -> + "Checksum file is missing for snapshot " <> showT snap LedgerDB.TookSnapshot snap pt RisingEdge -> "Taking ledger snapshot " <> showT snap <> @@ -665,8 +654,6 @@ instance ( ConvertRawHash blk ChainDB.InitChainSelValidation e -> case e of ChainDB.InvalidBlock _err _pt -> "Invalid block found during Initial chain selection, truncating the candidate and retrying to select a best candidate." ChainDB.ValidCandidate af -> "Valid candidate at tip " <> renderPointAsPhrase (AF.lastPoint af) - ChainDB.CandidateContainsFutureBlocks {} -> "Found a candidate containing future blocks during Initial chain selection, truncating the candidate and retrying to select a best candidate." - ChainDB.CandidateContainsFutureBlocksExceedingClockSkew {} -> "Found a candidate containing future blocks exceeding clock skew during Initial chain selection, truncating the candidate and retrying to select a best candidate." ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> let fromSlot = unSlotNo $ realPointSlot start atSlot = unSlotNo $ realPointSlot curr @@ -766,6 +753,9 @@ instance ( ConvertRawHash blk VolDb.Truncate e pth offs -> "Truncating the file at " <> showT pth <> " at offset " <> showT offs <> ": " <> showT e VolDb.InvalidFileNames fs -> "Invalid Volatile DB files: " <> showT fs VolDb.DBClosed -> "Closed Volatile DB." + ChainDB.TraceChainSelStarvationEvent ev -> case ev of + ChainDB.ChainSelStarvation RisingEdge -> "Chain Selection was starved." + ChainDB.ChainSelStarvation (FallingEdgeWith pt) -> "Chain Selection was unstarved by " <> renderRealPoint pt where showProgressT :: Int -> Int -> Text showProgressT chunkNo outOf = pack (showFFloat (Just 2) (100 * fromIntegral chunkNo / fromIntegral outOf :: Float) mempty) @@ -850,23 +840,6 @@ instance ( StandardHash blk ] -instance ( ConvertRawHash blk - , StandardHash blk - , ToObject (LedgerError blk) - , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (ValidationErr (BlockProtocol blk))) - => ToObject (ChainDB.InvalidBlockReason blk) where - toObject verb (ChainDB.ValidationError extvalerr) = - mconcat - [ "kind" .= String "ValidationError" - , "error" .= toObject verb extvalerr - ] - toObject verb (ChainDB.InFutureExceedsClockSkew point) = - mconcat - [ "kind" .= String "InFutureExceedsClockSkew" - , "point" .= toObject verb point - ] - instance (Show (PBFT.PBftVerKeyHash c)) => ToObject (PBFT.PBftValidationErr c) where toObject _verb (PBFT.PBftInvalidSignature text) = @@ -950,10 +923,6 @@ instance ( ConvertRawHash blk , case edgePt of RisingEdge -> "risingEdge" .= True FallingEdgeWith pt -> "block" .= toObject verb pt ] - ChainDB.BlockInTheFuture pt slot -> - mconcat [ "kind" .= String "TraceAddBlockEvent.BlockInTheFuture" - , "block" .= toObject verb pt - , "slot" .= toObject verb slot ] ChainDB.StoreButDontChange pt -> mconcat [ "kind" .= String "TraceAddBlockEvent.StoreButDontChange" , "block" .= toObject verb pt ] @@ -1004,14 +973,6 @@ instance ( ConvertRawHash blk ChainDB.ValidCandidate c -> mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.ValidCandidate" , "block" .= renderPointForVerbosity verb (AF.headPoint c) ] - ChainDB.CandidateContainsFutureBlocks c hdrs -> - mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.CandidateContainsFutureBlocks" - , "block" .= renderPointForVerbosity verb (AF.headPoint c) - , "headers" .= map (renderPointForVerbosity verb . headerPoint) hdrs ] - ChainDB.CandidateContainsFutureBlocksExceedingClockSkew c hdrs -> - mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.CandidateContainsFutureBlocksExceedingClockSkew" - , "block" .= renderPointForVerbosity verb (AF.headPoint c) - , "headers" .= map (renderPointForVerbosity verb . headerPoint) hdrs ] ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.UpdateLedgerDb" , "startingBlock" .= renderRealPoint start @@ -1023,9 +984,6 @@ instance ( ConvertRawHash blk , "block" .= toObject verb pt , "blockNo" .= show bn ] <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ] - ChainDB.ChainSelectionForFutureBlock pt -> - mconcat [ "kind" .= String "TraceAddBlockEvent.ChainSelectionForFutureBlock" - , "block" .= toObject verb pt ] ChainDB.PipeliningEvent ev' -> case ev' of ChainDB.SetTentativeHeader hdr enclosing -> mconcat $ [ "kind" .= String "TraceAddBlockEvent.PipeliningEvent.SetTentativeHeader" @@ -1061,7 +1019,6 @@ instance ( ConvertRawHash blk [ "anchor" .= renderPointForVerbosity verb (AF.anchorPoint frag) , "head" .= renderPointForVerbosity verb (AF.headPoint frag) ] - where addedHdrsNewChain :: AF.AnchoredFragment (Header blk) @@ -1103,6 +1060,10 @@ instance ( ConvertRawHash blk mconcat [ "kind" .= String "TraceSnapshotEvent.InvalidSnapshot" , "snapshot" .= toObject verb snap , "failure" .= show failure ] + LedgerDB.SnapshotMissingChecksum snap -> + mconcat [ "kind" .= String "TraceSnapshotEvent.SnapshotMissingChecksum" + , "snapshot" .= toObject verb snap + ] toObject verb (ChainDB.TraceCopyToImmutableDBEvent ev) = case ev of ChainDB.CopiedBlockToImmutableDB pt -> @@ -1169,14 +1130,6 @@ instance ( ConvertRawHash blk ChainDB.ValidCandidate c -> mconcat [ "kind" .= String "TraceInitChainSelEvent.ValidCandidate" , "block" .= renderPointForVerbosity verb (AF.headPoint c) ] - ChainDB.CandidateContainsFutureBlocks c hdrs -> - mconcat [ "kind" .= String "TraceInitChainSelEvent.CandidateContainsFutureBlocks" - , "block" .= renderPointForVerbosity verb (AF.headPoint c) - , "headers" .= map (renderPointForVerbosity verb . headerPoint) hdrs ] - ChainDB.CandidateContainsFutureBlocksExceedingClockSkew c hdrs -> - mconcat [ "kind" .= String "TraceInitChainSelEvent.CandidateContainsFutureBlocksExceedingClockSkew" - , "block" .= renderPointForVerbosity verb (AF.headPoint c) - , "headers" .= map (renderPointForVerbosity verb . headerPoint) hdrs ] ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr) ) -> mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.UpdateLedgerDbTraceEvent.StartedPushingBlockToTheLedgerDb" @@ -1292,6 +1245,12 @@ instance ( ConvertRawHash blk , "files" .= String (Text.pack . show $ map show fsPaths) ] VolDb.DBClosed -> mconcat [ "kind" .= String "TraceVolatileDbEvent.DBClosed"] + toObject verb (ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation edge)) = + mconcat [ "kind" .= String "ChainDB.ChainSelStarvation" + , case edge of + RisingEdge -> "risingEdge" .= True + FallingEdgeWith pt -> "fallingEdge" .= toObject verb pt + ] instance ConvertRawHash blk => ToObject (ImmDB.TraceChunkValidation blk ChunkNo) where toObject verb ev = case ev of @@ -1423,6 +1382,10 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk) mconcat [ "kind" .= String "ChainSyncClientEvent.TraceJumpingInstructionIs" , "instr" .= toObject verb instr ] + TraceDrainingThePipe n -> + mconcat [ "kind" .= String "ChainSyncClientEvent.TraceDrainingThePipe" + , "n" .= natToInt n + ] instance ( LedgerSupportsProtocol blk, ConvertRawHash blk @@ -1457,6 +1420,21 @@ instance ( LedgerSupportsProtocol blk, , "ourFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jOurFragment info)) , "theirFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jTheirFragment info)) ] +-- TODO @tweag-genesis +instance HasPrivacyAnnotation (ChainSync.Client.TraceEvent peer) where +instance HasSeverityAnnotation (ChainSync.Client.TraceEvent peer) where + getSeverityAnnotation _ = Info +instance Show peer => Transformable Text IO (ChainSync.Client.TraceEvent peer) where + trTransformer = trStructured + +instance Show peer => ToObject (ChainSync.Client.TraceEvent peer) where + toObject _verb (ChainSync.Client.RotatedDynamo fromPeer toPeer) = + mconcat + [ "kind" .= String "RotatedDynamo" + , "from" .= showT fromPeer + , "to" .= showT toPeer + ] + instance ConvertRawHash blk => ToObject (TraceChainSyncServerEvent blk) where toObject verb ev = case ev of diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index 5ca65ab077a..5c1207df009 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -22,7 +22,10 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} #endif -module Cardano.Tracing.OrphanInstances.Network () where +module Cardano.Tracing.OrphanInstances.Network + ( Verbose (..) + , FetchDecisionToJSON (..) + ) where import Cardano.Node.Queries (ConvertTxId) import Cardano.Tracing.OrphanInstances.Common @@ -39,19 +42,23 @@ import Ouroboros.Network.BlockFetch.ClientState (TraceFetchClientState TraceLabelPeer (..)) import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline (..)) +import qualified Ouroboros.Network.BlockFetch.Decision.Trace as BlockFetch import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) import Ouroboros.Network.ConnectionId (ConnectionId (..)) +import Ouroboros.Network.ConnectionManager.Core as ConnMgr (Trace (..)) +import Ouroboros.Network.ConnectionManager.ConnMap (ConnMap (..), LocalAddr (..)) +import Ouroboros.Network.ConnectionManager.State (ConnStateId (..)) import Ouroboros.Network.ConnectionManager.Types (AbstractState (..), - ConnectionManagerCounters (..), ConnectionManagerTrace (..), + ConnectionManagerCounters (..), OperationResult (..)) import qualified Ouroboros.Network.ConnectionManager.Types as ConnMgr import Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..)) import qualified Ouroboros.Network.Diffusion as ND import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (..)) +import qualified Ouroboros.Network.Driver.Stateful as Stateful import Ouroboros.Network.ExitPolicy (RepromoteDelay (..)) -import Ouroboros.Network.InboundGovernor (InboundGovernorTrace (..), RemoteSt (..)) import qualified Ouroboros.Network.InboundGovernor as InboundGovernor -import Ouroboros.Network.InboundGovernor.State (InboundGovernorCounters (..)) +import qualified Ouroboros.Network.InboundGovernor.State as InboundGovernor import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) import Ouroboros.Network.Magic (NetworkMagic (..)) import Ouroboros.Network.NodeToClient (NodeToClientVersion (..), @@ -79,6 +86,7 @@ import Ouroboros.Network.PeerSelection.State.KnownPeers (KnownPeerInfo import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), LocalRootPeers, WarmValency (..)) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers (LocalRootConfig (..)) import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers import Ouroboros.Network.PeerSelection.Types (PeerStatus (..)) import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch, Message (..)) @@ -86,6 +94,7 @@ import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync) import qualified Ouroboros.Network.Protocol.ChainSync.Type as ChainSync import Ouroboros.Network.Protocol.Handshake (HandshakeException (..), HandshakeProtocolError (..), RefuseReason (..)) +import qualified Ouroboros.Network.Protocol.KeepAlive.Type as KA import Ouroboros.Network.Protocol.LocalStateQuery.Type (LocalStateQuery) import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery import Ouroboros.Network.Protocol.LocalTxMonitor.Type (LocalTxMonitor) @@ -96,8 +105,7 @@ import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount PeerSharingResult (..)) import Ouroboros.Network.Protocol.TxSubmission2.Type as TxSubmission2 import Ouroboros.Network.RethrowPolicy (ErrorCommand (..)) -import Ouroboros.Network.Server2 (ServerTrace (..)) -import qualified Ouroboros.Network.Server2 as Server +import Ouroboros.Network.Server2 as Server import Ouroboros.Network.Snocket (LocalAddress (..)) import Ouroboros.Network.Subscription (ConnectResult (..), DnsTrace (..), SubscriberError (..), SubscriptionTrace (..), WithDomainName (..), @@ -122,10 +130,11 @@ import qualified Data.Set as Set import Data.Text (Text, pack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Network.Mux (MiniProtocolNum (..), MuxTrace (..), WithMuxBearer (..)) +import Network.Mux (MiniProtocolNum (..)) +import qualified Network.Mux as Mux import Network.Socket (SockAddr (..)) -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) -import Network.TypedProtocol.Core (PeerHasAgency (..)) +import Network.TypedProtocol.Codec (AnyMessage (AnyMessageAndAgency)) +import qualified Network.TypedProtocol.Stateful.Codec as Stateful {- HLINT ignore "Use record patterns" -} @@ -175,6 +184,11 @@ instance HasSeverityAnnotation (TraceSendRecv a) where getSeverityAnnotation _ = Debug +instance HasPrivacyAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) +instance HasSeverityAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) where + getSeverityAnnotation _ = Debug + + instance HasPrivacyAnnotation a => HasPrivacyAnnotation (TraceLabelPeer peer a) instance HasSeverityAnnotation a => HasSeverityAnnotation (TraceLabelPeer peer a) where getSeverityAnnotation (TraceLabelPeer _p a) = getSeverityAnnotation a @@ -204,6 +218,12 @@ instance HasSeverityAnnotation [TraceLabelPeer peer (FetchDecision [Point header Right _ -> Info +instance HasPrivacyAnnotation (BlockFetch.TraceDecisionEvent peer header) +instance HasSeverityAnnotation (BlockFetch.TraceDecisionEvent peer header) where + getSeverityAnnotation (BlockFetch.PeersFetch xs) = getSeverityAnnotation xs + getSeverityAnnotation BlockFetch.PeerStarvedUs {} = Info + + instance HasPrivacyAnnotation (TraceTxSubmissionInbound txid tx) instance HasSeverityAnnotation (TraceTxSubmissionInbound txid tx) where getSeverityAnnotation TraceTxSubmissionCollected {} = Debug @@ -243,6 +263,7 @@ instance HasSeverityAnnotation TraceLedgerPeers where TraceLedgerPeersDomains {} -> Debug TraceLedgerPeersResult {} -> Debug TraceLedgerPeersFailure {} -> Debug + UsingBigLedgerPeerSnapshot {} -> Debug instance HasPrivacyAnnotation (WithAddr addr ErrorPolicyTrace) @@ -369,38 +390,38 @@ instance ToObject (Identity (SubscriptionTrace LocalAddress)) where ] -instance HasPrivacyAnnotation (WithMuxBearer peer MuxTrace) -instance HasSeverityAnnotation (WithMuxBearer peer MuxTrace) where - getSeverityAnnotation (WithMuxBearer _ ev) = case ev of - MuxTraceRecvHeaderStart -> Debug - MuxTraceRecvHeaderEnd {} -> Debug - MuxTraceRecvStart {} -> Debug - MuxTraceRecvEnd {} -> Debug - MuxTraceSendStart {} -> Debug - MuxTraceSendEnd -> Debug - MuxTraceState {} -> Info - MuxTraceCleanExit {} -> Notice - MuxTraceExceptionExit {} -> Notice - MuxTraceChannelRecvStart {} -> Debug - MuxTraceChannelRecvEnd {} -> Debug - MuxTraceChannelSendStart {} -> Debug - MuxTraceChannelSendEnd {} -> Debug - MuxTraceHandshakeStart -> Debug - MuxTraceHandshakeClientEnd {} -> Info - MuxTraceHandshakeServerEnd -> Debug - MuxTraceHandshakeClientError {} -> Error - MuxTraceHandshakeServerError {} -> Error - MuxTraceRecvDeltaQObservation {} -> Debug - MuxTraceRecvDeltaQSample {} -> Debug - MuxTraceSDUReadTimeoutException -> Notice - MuxTraceSDUWriteTimeoutException -> Notice - MuxTraceStartEagerly _ _ -> Info - MuxTraceStartOnDemand _ _ -> Info - MuxTraceStartedOnDemand _ _ -> Info - MuxTraceTerminating {} -> Debug - MuxTraceStopping -> Debug - MuxTraceStopped -> Debug - MuxTraceTCPInfo {} -> Debug +instance HasPrivacyAnnotation (Mux.WithBearer peer Mux.Trace) +instance HasSeverityAnnotation (Mux.WithBearer peer Mux.Trace) where + getSeverityAnnotation (Mux.WithBearer _ ev) = case ev of + Mux.TraceRecvHeaderStart -> Debug + Mux.TraceRecvHeaderEnd {} -> Debug + Mux.TraceRecvStart {} -> Debug + Mux.TraceRecvEnd {} -> Debug + Mux.TraceSendStart {} -> Debug + Mux.TraceSendEnd -> Debug + Mux.TraceState {} -> Info + Mux.TraceCleanExit {} -> Notice + Mux.TraceExceptionExit {} -> Notice + Mux.TraceChannelRecvStart {} -> Debug + Mux.TraceChannelRecvEnd {} -> Debug + Mux.TraceChannelSendStart {} -> Debug + Mux.TraceChannelSendEnd {} -> Debug + Mux.TraceHandshakeStart -> Debug + Mux.TraceHandshakeClientEnd {} -> Info + Mux.TraceHandshakeServerEnd -> Debug + Mux.TraceHandshakeClientError {} -> Error + Mux.TraceHandshakeServerError {} -> Error + Mux.TraceRecvDeltaQObservation {} -> Debug + Mux.TraceRecvDeltaQSample {} -> Debug + Mux.TraceSDUReadTimeoutException -> Notice + Mux.TraceSDUWriteTimeoutException -> Notice + Mux.TraceStartEagerly _ _ -> Info + Mux.TraceStartOnDemand _ _ -> Info + Mux.TraceStartedOnDemand _ _ -> Info + Mux.TraceTerminating {} -> Debug + Mux.TraceStopping -> Debug + Mux.TraceStopped -> Debug + Mux.TraceTCPInfo {} -> Debug instance HasPrivacyAnnotation (TraceLocalRootPeers RemoteAddress exception) instance HasSeverityAnnotation (TraceLocalRootPeers RemoteAddress exception) where @@ -445,6 +466,7 @@ instance HasSeverityAnnotation (TracePeerSelection addr) where TraceGovernorWakeup {} -> Info TraceChurnWait {} -> Info TraceChurnMode {} -> Info + -- TraceVerifyPeerSnapshot {} -> Info TraceForgetBigLedgerPeers {} -> Info @@ -484,6 +506,9 @@ instance HasSeverityAnnotation (TracePeerSelection addr) where TraceDebugState {} -> Info + TraceVerifyPeerSnapshot True -> Info + TraceVerifyPeerSnapshot False -> Error + instance HasPrivacyAnnotation (DebugPeerSelection addr) instance HasSeverityAnnotation (DebugPeerSelection addr) where getSeverityAnnotation _ = Debug @@ -496,17 +521,18 @@ instance HasSeverityAnnotation (PeerSelectionActionsTrace SockAddr lAddr) where PeerStatusChangeFailure {} -> Error PeerMonitoringError {} -> Error PeerMonitoringResult {} -> Debug + AcquireConnectionError {} -> Error instance HasPrivacyAnnotation PeerSelectionCounters instance HasSeverityAnnotation PeerSelectionCounters where getSeverityAnnotation _ = Info -instance HasPrivacyAnnotation (ConnectionManagerTrace addr connTrace) -instance HasSeverityAnnotation (ConnectionManagerTrace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where +instance HasPrivacyAnnotation (ConnMgr.Trace addr connTrace) +instance HasSeverityAnnotation (ConnMgr.Trace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where getSeverityAnnotation ev = case ev of TrIncludeConnection {} -> Debug - TrUnregisterConnection {} -> Debug + TrReleaseConnection {} -> Debug TrConnect {} -> Debug TrConnectError {} -> Info TrTerminatingConnection {} -> Debug @@ -539,8 +565,8 @@ instance HasPrivacyAnnotation (ConnMgr.AbstractTransitionTrace addr) instance HasSeverityAnnotation (ConnMgr.AbstractTransitionTrace addr) where getSeverityAnnotation _ = Debug -instance HasPrivacyAnnotation (ServerTrace addr) -instance HasSeverityAnnotation (ServerTrace addr) where +instance HasPrivacyAnnotation (Server.Trace addr) +instance HasSeverityAnnotation (Server.Trace addr) where getSeverityAnnotation ev = case ev of Server.TrAcceptConnection {} -> Debug @@ -550,8 +576,8 @@ instance HasSeverityAnnotation (ServerTrace addr) where Server.TrServerStopped {} -> Notice Server.TrServerError {} -> Critical -instance HasPrivacyAnnotation (InboundGovernorTrace addr) -instance HasSeverityAnnotation (InboundGovernorTrace addr) where +instance HasPrivacyAnnotation (InboundGovernor.Trace addr) +instance HasSeverityAnnotation (InboundGovernor.Trace addr) where getSeverityAnnotation ev = case ev of InboundGovernor.TrNewConnection {} -> Debug @@ -607,7 +633,7 @@ instance HasTextFormatter NtN.AcceptConnectionsPolicyTrace where formatText a _ = pack (show a) -instance (StandardHash header, Show peer, ToObject peer) +instance (StandardHash header, Show peer, ToJSON peer, ConvertRawHash header) => Transformable Text IO [TraceLabelPeer peer (FetchDecision [Point header])] where trTransformer = trStructuredText instance (StandardHash header, Show peer) @@ -621,6 +647,13 @@ instance (Show header, StandardHash header, Show peer) => HasTextFormatter (TraceLabelPeer peer (TraceFetchClientState header)) where formatText a _ = pack (show a) +instance (StandardHash header, Show peer, ToJSON peer, ConvertRawHash header) + => Transformable Text IO (BlockFetch.TraceDecisionEvent peer header) where + trTransformer = trStructuredText +instance (StandardHash header, Show peer) + => HasTextFormatter (BlockFetch.TraceDecisionEvent peer header) where + formatText a _ = pack (show a) + instance ToObject peer => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))) where trTransformer = trStructured @@ -628,7 +661,7 @@ instance (Show peer, StandardHash blk, Show (Header blk)) => HasTextFormatter (TraceLabelPeer peer (NtN.TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))) where formatText a _ = pack (show a) -instance (ToObject peer, ToObject (AnyMessageAndAgency (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) +instance (ToObject peer, ToObject (AnyMessage (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) where trTransformer = trStructured @@ -656,6 +689,17 @@ instance (LocalStateQuery.ShowQuery (BlockQuery blk), ToObject localPeer) => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)))) where trTransformer = trStructured +instance (ToObject localPeer) + => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv KA.KeepAlive)) where + trTransformer = trStructured + +instance + ( HasPrivacyAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) + , HasSeverityAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) + , LocalStateQuery.ShowQuery (BlockQuery blk), ToObject localPeer) + => Transformable Text IO (TraceLabelPeer localPeer (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f)) where + trTransformer = trStructured + instance (ToObject peer, Show (TxId (GenTx blk)), Show (GenTx blk)) => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk)))) where trTransformer = trStructured @@ -717,11 +761,11 @@ instance HasTextFormatter (WithIPList (SubscriptionTrace SockAddr)) where instance (Show peer, ToObject peer) - => Transformable Text IO (WithMuxBearer peer MuxTrace) where + => Transformable Text IO (Mux.WithBearer peer Mux.Trace) where trTransformer = trStructuredText instance (Show peer) - => HasTextFormatter (WithMuxBearer peer MuxTrace) where - formatText (WithMuxBearer peer ev) _o = + => HasTextFormatter (Mux.WithBearer peer Mux.Trace) where + formatText (Mux.WithBearer peer ev) _o = "Bearer on " <> pack (show peer) <> " event: " <> pack (show ev) @@ -761,12 +805,12 @@ instance HasTextFormatter PeerSelectionCounters where instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, ToJSON addr, ToJSON versionNumber, ToJSON agreedOptions ) - => Transformable Text IO (ConnectionManagerTrace + => Transformable Text IO (ConnMgr.Trace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where trTransformer = trStructuredText instance (Show addr, Show versionNumber, Show agreedOptions) - => HasTextFormatter (ConnectionManagerTrace + => HasTextFormatter (ConnMgr.Trace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where formatText a _ = pack (show a) @@ -779,17 +823,17 @@ instance Show addr formatText a _ = pack (show a) instance (Show addr, ToObject addr, ToJSON addr) - => Transformable Text IO (ServerTrace addr) where + => Transformable Text IO (Server.Trace addr) where trTransformer = trStructuredText instance Show addr - => HasTextFormatter (ServerTrace addr) where + => HasTextFormatter (Server.Trace addr) where formatText a _ = pack (show a) instance (ToJSON addr, Show addr) - => Transformable Text IO (InboundGovernorTrace addr) where + => Transformable Text IO (InboundGovernor.Trace addr) where trTransformer = trStructuredText instance Show addr - => HasTextFormatter (InboundGovernorTrace addr) where + => HasTextFormatter (InboundGovernor.Trace addr) where formatText a _ = pack (show a) instance (Show addr, ToJSON addr) @@ -808,7 +852,7 @@ instance ( ConvertTxId blk , RunNode blk , HasTxs blk ) - => ToObject (AnyMessageAndAgency (BlockFetch blk (Point blk))) where + => ToObject (AnyMessage (BlockFetch blk (Point blk))) where toObject MinimalVerbosity (AnyMessageAndAgency stok (MsgBlock blk)) = mconcat [ "kind" .= String "MsgBlock" , "agency" .= String (pack $ show stok) @@ -849,7 +893,7 @@ instance ( ConvertTxId blk ] instance (forall result. Show (query result)) - => ToObject (AnyMessageAndAgency (LocalStateQuery blk pt query)) where + => ToObject (AnyMessage (LocalStateQuery blk pt query)) where toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgAcquire{}) = mconcat [ "kind" .= String "MsgAcquire" , "agency" .= String (pack $ show stok) @@ -883,7 +927,42 @@ instance (forall result. Show (query result)) , "agency" .= String (pack $ show stok) ] -instance ToObject (AnyMessageAndAgency (LocalTxMonitor txid tx slotno)) where +instance (forall result. Show (query result)) + => ToObject (Stateful.AnyMessage (LocalStateQuery blk pt query) f) where + toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgAcquire{}) = + mconcat [ "kind" .= String "MsgAcquire" + , "agency" .= String (pack $ show stok) + ] + toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgAcquired{}) = + mconcat [ "kind" .= String "MsgAcquired" + , "agency" .= String (pack $ show stok) + ] + toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgFailure{}) = + mconcat [ "kind" .= String "MsgFailure" + , "agency" .= String (pack $ show stok) + ] + toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgQuery{}) = + mconcat [ "kind" .= String "MsgQuery" + , "agency" .= String (pack $ show stok) + ] + toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgResult{}) = + mconcat [ "kind" .= String "MsgResult" + , "agency" .= String (pack $ show stok) + ] + toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgRelease{}) = + mconcat [ "kind" .= String "MsgRelease" + , "agency" .= String (pack $ show stok) + ] + toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgReAcquire{}) = + mconcat [ "kind" .= String "MsgReAcquire" + , "agency" .= String (pack $ show stok) + ] + toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgDone{}) = + mconcat [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + +instance ToObject (AnyMessage (LocalTxMonitor txid tx slotno)) where toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgAcquire {}) = mconcat [ "kind" .= String "MsgAcuire" , "agency" .= String (pack $ show stok) @@ -929,7 +1008,7 @@ instance ToObject (AnyMessageAndAgency (LocalTxMonitor txid tx slotno)) where , "agency" .= String (pack $ show stok) ] -instance ToObject (AnyMessageAndAgency (LocalTxSubmission tx err)) where +instance ToObject (AnyMessage (LocalTxSubmission tx err)) where toObject _verb (AnyMessageAndAgency stok LocalTxSub.MsgSubmitTx{}) = mconcat [ "kind" .= String "MsgSubmitTx" , "agency" .= String (pack $ show stok) @@ -947,7 +1026,7 @@ instance ToObject (AnyMessageAndAgency (LocalTxSubmission tx err)) where , "agency" .= String (pack $ show stok) ] -instance ToObject (AnyMessageAndAgency (ChainSync blk pt tip)) where +instance ToObject (AnyMessage (ChainSync blk pt tip)) where toObject _verb (AnyMessageAndAgency stok ChainSync.MsgRequestNext{}) = mconcat [ "kind" .= String "MsgRequestNext" , "agency" .= String (pack $ show stok) @@ -982,7 +1061,7 @@ instance ToObject (AnyMessageAndAgency (ChainSync blk pt tip)) where ] instance (Show txid, Show tx) - => ToObject (AnyMessageAndAgency (TxSubmission2 txid tx)) where + => ToObject (AnyMessage (TxSubmission2 txid tx)) where toObject _verb (AnyMessageAndAgency stok MsgInit) = mconcat [ "kind" .= String "MsgInit" @@ -1016,6 +1095,23 @@ instance (Show txid, Show tx) , "agency" .= String (pack $ show stok) ] +instance ToObject (AnyMessage KA.KeepAlive) where + toObject _verb (AnyMessageAndAgency stok KA.MsgKeepAlive {}) = + mconcat + [ "kind" .= String "MsgKeepAlive" + , "agency" .= String (pack $ show stok) + ] + toObject _verb (AnyMessageAndAgency stok KA.MsgKeepAliveResponse {}) = + mconcat + [ "kind" .= String "MsgKeepAliveResponse" + , "agency" .= String (pack $ show stok) + ] + toObject _verb (AnyMessageAndAgency stok KA.MsgDone) = + mconcat + [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + instance ToJSON peerAddr => ToJSON (ConnectionId peerAddr) where toJSON ConnectionId { localAddress, remoteAddress } = Aeson.object [ "localAddress" .= toJSON localAddress @@ -1036,16 +1132,6 @@ instance Aeson.ToJSON ConnectionManagerCounters where , "outbound" .= outboundConns ] -instance ToObject (FetchDecision [Point header]) where - toObject _verb (Left decline) = - mconcat [ "kind" .= String "FetchDecision declined" - , "declined" .= String (pack (show decline)) - ] - toObject _verb (Right results) = - mconcat [ "kind" .= String "FetchDecision results" - , "length" .= String (pack $ show $ length results) - ] - -- TODO: use 'ToJSON' constraints instance (Show ntnAddr, Show ntcAddr) => ToObject (ND.DiffusionTracer ntnAddr ntcAddr) where toObject _verb (ND.RunServer sockAddr) = mconcat @@ -1118,14 +1204,14 @@ instance (Show ntnAddr, Show ntcAddr) => ToObject (ND.DiffusionTracer ntnAddr nt ] instance ToObject (NtC.HandshakeTr LocalAddress NodeToClientVersion) where - toObject _verb (WithMuxBearer b ev) = + toObject _verb (Mux.WithBearer b ev) = mconcat [ "kind" .= String "LocalHandshakeTrace" , "bearer" .= show b , "event" .= show ev ] instance ToObject (NtN.HandshakeTr RemoteAddress NodeToNodeVersion) where - toObject _verb (WithMuxBearer b ev) = + toObject _verb (Mux.WithBearer b ev) = mconcat [ "kind" .= String "HandshakeTrace" , "bearer" .= show b , "event" .= show ev ] @@ -1151,17 +1237,45 @@ instance ToObject NtN.AcceptConnectionsPolicyTrace where ] +instance ConvertRawHash header + => ToJSON (Point header) where + toJSON GenesisPoint = String "GenesisPoint" + toJSON (BlockPoint (SlotNo slotNo) hash) = + -- it is unlikely that there will be two short hashes in the same slot + String $ renderHeaderHashForVerbosity + (Proxy @header) + MinimalVerbosity + hash + <> "@" + <> pack (show slotNo) + + +newtype Verbose a = Verbose a + +instance ConvertRawHash header + => ToJSON (Verbose (Point header)) where + toJSON (Verbose GenesisPoint) = String "GenesisPoint" + toJSON (Verbose (BlockPoint (SlotNo slotNo) hash)) = + -- it is unlikely that there will be two short hashes in the same slot + String $ renderHeaderHashForVerbosity + (Proxy @header) + MaximalVerbosity + hash + <> "@" + <> pack (show slotNo) + + instance ConvertRawHash blk => ToObject (Point blk) where toObject _verb GenesisPoint = - mconcat - [ "kind" .= String "GenesisPoint" ] - toObject verb (BlockPoint slot h) = - mconcat - [ "kind" .= String "BlockPoint" - , "slot" .= toJSON (unSlotNo slot) - , "headerHash" .= renderHeaderHashForVerbosity (Proxy @blk) verb h - ] + mconcat [ "point" .= String "GenesisPoint" ] + toObject verb point@BlockPoint{} = + mconcat [ "point" .= + case verb of + MaximalVerbosity + -> toJSON (Verbose point) + _ -> toJSON point + ] instance ToObject SlotNo where @@ -1237,22 +1351,54 @@ instance (HasHeader header, ConvertRawHash header) , "outstanding" .= outstanding ] - -instance (ToObject peer) +instance (ToJSON peer, ConvertRawHash header) => ToObject [TraceLabelPeer peer (FetchDecision [Point header])] where toObject MinimalVerbosity _ = mempty toObject _ [] = mempty toObject _ xs = mconcat - [ "kind" .= String "PeersFetch" - , "peers" .= toJSON - (foldl' (\acc x -> toObject MaximalVerbosity x : acc) [] xs) ] + [ "kind" .= String "FetchDecisions" + , "decisions" .= toJSON xs + ] instance (ToObject peer, ToObject a) => ToObject (TraceLabelPeer peer a) where toObject verb (TraceLabelPeer peerid a) = mconcat [ "peer" .= toObject verb peerid ] <> toObject verb a +instance (ToJSON peer, ToJSON point) + => ToJSON (TraceLabelPeer peer (FetchDecision [point])) where + toJSON (TraceLabelPeer peer decision) = + Aeson.object + [ "peer" .= toJSON peer + , "decision" .= toJSON (FetchDecisionToJSON decision) + ] + +instance (ToJSON peer, ToJSON (Verbose point)) + => ToJSON (Verbose (TraceLabelPeer peer (FetchDecision [point]))) where + toJSON (Verbose (TraceLabelPeer peer decision)) = + Aeson.object + [ "peer" .= toJSON peer + , "decision" .= toJSON (FetchDecisionToJSON $ map Verbose <$> decision) + ] + +newtype FetchDecisionToJSON point = + FetchDecisionToJSON (FetchDecision [point]) + +instance ToJSON point + => ToJSON (FetchDecisionToJSON point) where + toJSON (FetchDecisionToJSON (Left decline)) = + Aeson.object [ "declined" .= String (pack . show $ decline) ] + toJSON (FetchDecisionToJSON (Right points)) = + toJSON points + +instance (ToJSON peer, ConvertRawHash header) + => ToObject (BlockFetch.TraceDecisionEvent peer header) where + toObject verb (BlockFetch.PeersFetch as) = toObject verb as + toObject _verb (BlockFetch.PeerStarvedUs peer) = mconcat + [ "kind" .= String "PeerStarvedUs" + , "peer" .= toJSON peer + ] -instance ToObject (AnyMessageAndAgency ps) +instance ToObject (AnyMessage ps) => ToObject (TraceSendRecv ps) where toObject verb (TraceSendMsg m) = mconcat [ "kind" .= String "Send" , "msg" .= toObject verb m ] @@ -1260,6 +1406,14 @@ instance ToObject (AnyMessageAndAgency ps) [ "kind" .= String "Recv" , "msg" .= toObject verb m ] +instance ToObject (Stateful.AnyMessage ps f) + => ToObject (Stateful.TraceSendRecv ps f) where + toObject verb (Stateful.TraceSendMsg m) = mconcat + [ "kind" .= String "Send" , "msg" .= toObject verb m ] + toObject verb (Stateful.TraceRecvMsg m) = mconcat + [ "kind" .= String "Recv" , "msg" .= toObject verb m ] + + instance ToObject (TraceTxSubmissionInbound txid tx) where toObject _verb (TraceTxSubmissionCollected count) = mconcat @@ -1440,7 +1594,10 @@ instance ToObject TraceLedgerPeers where , "domainAccessPoint" .= show dap , "error" .= show reason ] - + toObject _verb UsingBigLedgerPeerSnapshot = + mconcat + [ "kind" .= String "UsingBigLedgerPeerSnapshot" + ] instance Show addr => ToObject (WithAddr addr ErrorPolicyTrace) where @@ -1472,9 +1629,9 @@ instance ToObject (WithDomainName (SubscriptionTrace SockAddr)) where , "event" .= show ev ] -instance ToObject peer => ToObject (WithMuxBearer peer MuxTrace) where - toObject verb (WithMuxBearer b ev) = - mconcat [ "kind" .= String "MuxTrace" +instance ToObject peer => ToObject (Mux.WithBearer peer Mux.Trace) where + toObject verb (Mux.WithBearer b ev) = + mconcat [ "kind" .= String "Mux.Trace" , "bearer" .= toObject verb b , "event" .= show ev ] @@ -1491,6 +1648,16 @@ instance FromJSON HotValency where instance FromJSON WarmValency where parseJSON v = WarmValency <$> parseJSON v +instance ToJSON LocalRootConfig where + toJSON LocalRootConfig { peerAdvertise, + peerTrustable, + diffusionMode } = + Aeson.object + [ "peerAdvertise" .= peerAdvertise + , "peerTrustable" .= peerTrustable + , "diffusionMode" .= show diffusionMode + ] + instance Show exception => ToObject (TraceLocalRootPeers RemoteAddress exception) where toObject _verb (TraceLocalRootDomains groups) = mconcat [ "kind" .= String "LocalRootDomains" @@ -1918,6 +2085,9 @@ instance ToObject (TracePeerSelection SockAddr) where toObject _verb TraceBootstrapPeersFlagChangedWhilstInSensitiveState = mconcat [ "kind" .= String "BootstrapPeersFlagChangedWhilstInSensitiveState" ] + toObject _verb (TraceVerifyPeerSnapshot result) = + mconcat [ "kind" .= String "VerifyPeerSnapshot" + , "result" .= toJSON result ] toObject _verb (TraceOutboundGovernorCriticalFailure err) = mconcat [ "kind" .= String "OutboundGovernorCriticalFailure" , "reason" .= show err @@ -2059,6 +2229,10 @@ instance Show lAddr => ToObject (PeerSelectionActionsTrace SockAddr lAddr) where , "connectionId" .= toJSON connId , "withProtocolTemp" .= show wf ] + toObject _verb (AcquireConnectionError exception) = + mconcat [ "kind" .= String "AcquireConnectionError" + , "error" .= displayException exception + ] instance ToObject PeerSelectionCounters where toObject _verb PeerSelectionCounters {..} = @@ -2104,25 +2278,14 @@ instance ToObject PeerSelectionCounters where , "activeBootstrapPeersDemotions" .= numberOfActiveBootstrapPeersDemotions ] -instance (Show (ClientHasAgency st), Show (ServerHasAgency st)) - => ToJSON (PeerHasAgency pr st) where - toJSON (ClientAgency cha) = - Aeson.object [ "kind" .= String "ClientAgency" - , "agency" .= show cha - ] - toJSON (ServerAgency sha) = - Aeson.object [ "kind" .= String "ServerAgency" - , "agency" .= show sha - ] - instance ToJSON ProtocolLimitFailure where toJSON (ExceededSizeLimit tok) = Aeson.object [ "kind" .= String "ProtocolLimitFailure" - , "agency" .= toJSON tok + , "agency" .= show tok ] toJSON (ExceededTimeLimit tok) = Aeson.object [ "kind" .= String "ProtocolLimitFailure" - , "agency" .= toJSON tok + , "agency" .= show tok ] instance Show vNumber => ToJSON (RefuseReason vNumber) where @@ -2181,29 +2344,17 @@ instance FromJSON NodeToNodeVersion where parseJSON x = fail ("FromJSON.NodeToNodeVersion: error parsing NodeToNodeVersion: " ++ show x) instance ToJSON NodeToClientVersion where - toJSON NodeToClientV_9 = Number 9 - toJSON NodeToClientV_10 = Number 10 - toJSON NodeToClientV_11 = Number 11 - toJSON NodeToClientV_12 = Number 12 - toJSON NodeToClientV_13 = Number 13 - toJSON NodeToClientV_14 = Number 14 - toJSON NodeToClientV_15 = Number 15 toJSON NodeToClientV_16 = Number 16 toJSON NodeToClientV_17 = Number 17 toJSON NodeToClientV_18 = Number 18 + toJSON NodeToClientV_19 = Number 19 -- NB: When adding a new version here, update FromJSON below as well! instance FromJSON NodeToClientVersion where - parseJSON (Number 9) = return NodeToClientV_9 - parseJSON (Number 10) = return NodeToClientV_10 - parseJSON (Number 11) = return NodeToClientV_11 - parseJSON (Number 12) = return NodeToClientV_12 - parseJSON (Number 13) = return NodeToClientV_13 - parseJSON (Number 14) = return NodeToClientV_14 - parseJSON (Number 15) = return NodeToClientV_15 parseJSON (Number 16) = return NodeToClientV_16 parseJSON (Number 17) = return NodeToClientV_17 parseJSON (Number 18) = return NodeToClientV_18 + parseJSON (Number 19) = return NodeToClientV_19 parseJSON (Number x) = fail ("FromJSON.NodeToClientVersion: unsupported node-to-client protocol version " ++ show x) parseJSON x = fail ("FromJSON.NodeToClientVersion: error parsing NodeToClientVersion: " ++ show x) @@ -2255,9 +2406,22 @@ instance (Show versionNumber, ToJSON versionNumber, ToJSON agreedOptions) , "command" .= show cerr ] +instance ToJSON addr => ToJSON (LocalAddr addr) where + toJSON (LocalAddr addr) = toJSON addr + toJSON UnknownLocalAddr = Null + +instance ToJSON NtN.DiffusionMode where + toJSON = String . pack . show + +instance ToJSON ConnStateId where + toJSON (ConnStateId connStateId) = toJSON connStateId + +instance ToObject ConnStateId where + toObject _ connStateId = mconcat [ "connStateId" .= toJSON connStateId ] + instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, ToJSON addr, ToJSON versionNumber, ToJSON agreedOptions) - => ToObject (ConnectionManagerTrace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where + => ToObject (ConnMgr.Trace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where toObject verb ev = case ev of TrIncludeConnection prov peerAddr -> @@ -2266,21 +2430,23 @@ instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, , "remoteAddress" .= toObject verb peerAddr , "provenance" .= String (pack . show $ prov) ] - TrUnregisterConnection prov peerAddr -> + TrReleaseConnection prov connId -> mconcat $ reverse [ "kind" .= String "UnregisterConnection" - , "remoteAddress" .= toObject verb peerAddr + , "remoteAddress" .= toJSON connId , "provenance" .= String (pack . show $ prov) ] - TrConnect (Just localAddress) remoteAddress -> + TrConnect (Just localAddress) remoteAddress diffusionMode -> mconcat - [ "kind" .= String "ConnectTo" + [ "kind" .= String "Connect" , "connectionId" .= toJSON ConnectionId { localAddress, remoteAddress } + , "diffusionMode" .= toJSON diffusionMode ] - TrConnect Nothing remoteAddress -> + TrConnect Nothing remoteAddress diffusionMode -> mconcat - [ "kind" .= String "ConnectTo" + [ "kind" .= String "Connect" , "remoteAddress" .= toObject verb remoteAddress + , "diffusionMode" .= toJSON diffusionMode ] TrConnectError (Just localAddress) remoteAddress err -> mconcat @@ -2350,7 +2516,7 @@ instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, [ "kind" .= String "PruneConnections" , "prunedPeers" .= toJSON pruningSet , "numberPrunedPeers" .= toJSON numberPruned - , "choiceSet" .= toJSON (toObject verb `Set.map` chosenPeers) + , "choiceSet" .= toJSON (toJSON `Set.map` chosenPeers) ] TrConnectionCleanup connId -> mconcat @@ -2375,12 +2541,20 @@ instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, TrState cmState -> mconcat [ "kind" .= String "ConnectionManagerState" - , "state" .= listValue (\(addr, connState) -> + , "state" .= listValue (\(remoteAddr, inner) -> Aeson.object - [ "remoteAddress" .= toJSON addr - , "connectionState" .= toJSON connState - ]) - (Map.toList cmState) + [ "connections" .= + listValue (\(localAddr, connState) -> + Aeson.object + [ "localAddress" .= localAddr + , "state" .= toJSON connState + ] + ) + (Map.toList inner) + , "remoteAddress" .= toJSON remoteAddr + ] + ) + (Map.toList (getConnMap cmState)) ] ConnMgr.TrUnexpectedlyFalseAssertion info -> mconcat @@ -2414,27 +2588,27 @@ instance (Show addr, ToObject addr, ToJSON addr) ] instance (Show addr, ToObject addr, ToJSON addr) - => ToObject (ServerTrace addr) where - toObject verb (TrAcceptConnection peerAddr) = + => ToObject (Server.Trace addr) where + toObject _verb (Server.TrAcceptConnection connId) = mconcat [ "kind" .= String "AcceptConnection" - , "address" .= toObject verb peerAddr + , "connectionId" .= toJSON connId ] - toObject _verb (TrAcceptError exception) = + toObject _verb (Server.TrAcceptError exception) = mconcat [ "kind" .= String "AcceptErroor" , "reason" .= show exception ] - toObject verb (TrAcceptPolicyTrace policyTrace) = - mconcat [ "kind" .= String "AcceptPolicyTrace" + toObject verb (Server.TrAcceptPolicyTrace policyTrace) = + mconcat [ "kind" .= String "AcceptPolicyServer.Trace" , "policy" .= toObject verb policyTrace ] - toObject verb (TrServerStarted peerAddrs) = - mconcat [ "kind" .= String "AcceptPolicyTrace" + toObject verb (Server.TrServerStarted peerAddrs) = + mconcat [ "kind" .= String "AcceptPolicyServer.Trace" , "addresses" .= toJSON (toObject verb `map` peerAddrs) ] - toObject _verb TrServerStopped = + toObject _verb Server.TrServerStopped = mconcat [ "kind" .= String "ServerStopped" ] - toObject _verb (TrServerError exception) = + toObject _verb (Server.TrServerError exception) = mconcat [ "kind" .= String "ServerError" , "reason" .= show exception ] @@ -2497,79 +2671,79 @@ instance ToObject NtC.LocalConnectionId where , "remote" .= toObject verb r ] instance (ToJSON addr, Show addr) - => ToObject (InboundGovernorTrace addr) where - toObject _verb (TrNewConnection p connId) = + => ToObject (InboundGovernor.Trace addr) where + toObject _verb (InboundGovernor.TrNewConnection p connId) = mconcat [ "kind" .= String "NewConnection" , "provenance" .= show p , "connectionId" .= toJSON connId ] - toObject _verb (TrResponderRestarted connId m) = + toObject _verb (InboundGovernor.TrResponderRestarted connId m) = mconcat [ "kind" .= String "ResponderStarted" , "connectionId" .= toJSON connId , "miniProtocolNum" .= toJSON m ] - toObject _verb (TrResponderStartFailure connId m s) = + toObject _verb (InboundGovernor.TrResponderStartFailure connId m s) = mconcat [ "kind" .= String "ResponderStartFailure" , "connectionId" .= toJSON connId , "miniProtocolNum" .= toJSON m , "reason" .= show s ] - toObject _verb (TrResponderErrored connId m s) = + toObject _verb (InboundGovernor.TrResponderErrored connId m s) = mconcat [ "kind" .= String "ResponderErrored" , "connectionId" .= toJSON connId , "miniProtocolNum" .= toJSON m , "reason" .= show s ] - toObject _verb (TrResponderStarted connId m) = + toObject _verb (InboundGovernor.TrResponderStarted connId m) = mconcat [ "kind" .= String "ResponderStarted" , "connectionId" .= toJSON connId , "miniProtocolNum" .= toJSON m ] - toObject _verb (TrResponderTerminated connId m) = + toObject _verb (InboundGovernor.TrResponderTerminated connId m) = mconcat [ "kind" .= String "ResponderTerminated" , "connectionId" .= toJSON connId , "miniProtocolNum" .= toJSON m ] - toObject _verb (TrPromotedToWarmRemote connId opRes) = + toObject _verb (InboundGovernor.TrPromotedToWarmRemote connId opRes) = mconcat [ "kind" .= String "PromotedToWarmRemote" , "connectionId" .= toJSON connId , "result" .= toJSON opRes ] - toObject _verb (TrPromotedToHotRemote connId) = + toObject _verb (InboundGovernor.TrPromotedToHotRemote connId) = mconcat [ "kind" .= String "PromotedToHotRemote" , "connectionId" .= toJSON connId ] - toObject _verb (TrDemotedToColdRemote connId od) = + toObject _verb (InboundGovernor.TrDemotedToColdRemote connId od) = mconcat [ "kind" .= String "DemotedToColdRemote" , "connectionId" .= toJSON connId , "result" .= show od ] - toObject _verb (TrDemotedToWarmRemote connId) = + toObject _verb (InboundGovernor.TrDemotedToWarmRemote connId) = mconcat [ "kind" .= String "DemotedToWarmRemote" , "connectionId" .= toJSON connId ] - toObject _verb (TrWaitIdleRemote connId opRes) = + toObject _verb (InboundGovernor.TrWaitIdleRemote connId opRes) = mconcat [ "kind" .= String "WaitIdleRemote" , "connectionId" .= toJSON connId , "result" .= toJSON opRes ] - toObject _verb (TrMuxCleanExit connId) = + toObject _verb (InboundGovernor.TrMuxCleanExit connId) = mconcat [ "kind" .= String "MuxCleanExit" , "connectionId" .= toJSON connId ] - toObject _verb (TrMuxErrored connId s) = + toObject _verb (InboundGovernor.TrMuxErrored connId s) = mconcat [ "kind" .= String "MuxErrored" , "connectionId" .= toJSON connId , "reason" .= show s ] - toObject _verb (TrInboundGovernorCounters counters) = + toObject _verb (InboundGovernor.TrInboundGovernorCounters counters) = mconcat [ "kind" .= String "InboundGovernorCounters" - , "idlePeers" .= idlePeersRemote counters - , "coldPeers" .= coldPeersRemote counters - , "warmPeers" .= warmPeersRemote counters - , "hotPeers" .= hotPeersRemote counters + , "idlePeers" .= InboundGovernor.idlePeersRemote counters + , "coldPeers" .= InboundGovernor.coldPeersRemote counters + , "warmPeers" .= InboundGovernor.warmPeersRemote counters + , "hotPeers" .= InboundGovernor.hotPeersRemote counters ] - toObject _verb (TrRemoteState st) = + toObject _verb (InboundGovernor.TrRemoteState st) = mconcat [ "kind" .= String "RemoteState" , "remoteSt" .= toJSON st ] diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index 4d93eaea489..7bba56ed962 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -170,10 +170,10 @@ instance ToObject (Conway.ConwayGovCertPredFailure era) where , "credential" .= String (textShow credential) , "error" .= String "DRep is not registered" ] - Conway.ConwayDRepIncorrectDeposit givenCoin expectedCoin -> + Conway.ConwayDRepIncorrectDeposit Mismatch {mismatchSupplied, mismatchExpected} -> [ "kind" .= String "ConwayDRepIncorrectDeposit" - , "givenCoin" .= givenCoin - , "expectedCoin" .= expectedCoin + , "givenCoin" .= mismatchSupplied + , "expectedCoin" .= mismatchExpected , "error" .= String "DRep delegation has incorrect deposit" ] Conway.ConwayCommitteeHasPreviouslyResigned kHash -> @@ -186,10 +186,10 @@ instance ToObject (Conway.ConwayGovCertPredFailure era) where , "credential" .= String (textShow kHash) , "error" .= String "Committee is Unknown" ] - Conway.ConwayDRepIncorrectRefund givenRefund expectedRefund -> + Conway.ConwayDRepIncorrectRefund Mismatch {mismatchSupplied, mismatchExpected} -> [ "kind" .= String "ConwayDRepIncorrectRefund" - , "givenRefund" .= String (textShow givenRefund) - , "expectedRefund" .= String (textShow expectedRefund) + , "givenRefund" .= String (textShow mismatchSupplied) + , "expectedRefund" .= String (textShow mismatchExpected) , "error" .= String "Refund given does not match the expected one" ] @@ -325,18 +325,18 @@ instance , ToObject (NonEmpty.NonEmpty (KeyHash 'Staking (Consensus.EraCrypto ledgerera))) ) => ToObject (Conway.ConwayLedgerPredFailure ledgerera) where toObject verb (Conway.ConwayUtxowFailure f) = toObject verb f - toObject _ (Conway.ConwayTxRefScriptsSizeTooBig actual limit) = + toObject _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" - , "actual" .= actual - , "limit" .= limit + , "actual" .= mismatchSupplied + , "limit" .= mismatchExpected ] toObject verb (Conway.ConwayCertsFailure f) = toObject verb f toObject verb (Conway.ConwayGovFailure f) = toObject verb f toObject verb (Conway.ConwayWdrlNotDelegatedToDRep f) = toObject verb f - toObject _ (Conway.ConwayTreasuryValueMismatch actual inTx) = + toObject _ (Conway.ConwayTreasuryValueMismatch Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTreasuryValueMismatch" - , "actual" .= actual - , "submittedInTx" .= inTx + , "actual" .= mismatchExpected + , "submittedInTx" .= mismatchSupplied ] toObject _ (Conway.ConwayMempoolFailure msg) = mconcat [ "kind" .= String "ConwayMempoolFailure" @@ -363,10 +363,10 @@ instance Ledger.EraPParams era => ToObject (Conway.ConwayGovPredFailure era) whe , "rewardAccounts" .= toJSON rewardAcnts , "expectedNetworkId" .= toJSON network ] - toObject _ (Conway.ProposalDepositIncorrect deposit expectedDeposit) = + toObject _ (Conway.ProposalDepositIncorrect Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ProposalDepositIncorrect" - , "deposit" .= deposit - , "expectedDeposit" .= expectedDeposit + , "deposit" .= mismatchSupplied + , "expectedDeposit" .= mismatchExpected ] toObject _ (Conway.DisallowedVoters govActionIdToVoter) = mconcat [ "kind" .= String "DisallowedVoters" @@ -392,11 +392,11 @@ instance Ledger.EraPParams era => ToObject (Conway.ConwayGovPredFailure era) whe mconcat [ "kind" .= String "VotingOnExpiredGovAction" , "action" .= actions ] - toObject _ (Conway.ProposalCantFollow prevGovActionId protVer prevProtVer) = + toObject _ (Conway.ProposalCantFollow prevGovActionId Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ProposalCantFollow" , "prevGovActionId" .= prevGovActionId - , "protVer" .= protVer - , "prevProtVer" .= prevProtVer + , "protVer" .= mismatchSupplied + , "prevProtVer" .= mismatchExpected ] toObject _ (Conway.InvalidPolicyHash actualPolicyHash expectedPolicyHash) = mconcat [ "kind" .= String "InvalidPolicyHash" @@ -461,10 +461,10 @@ instance , "received" .= map (Crypto.hashToTextAsHex . SafeHash.extractHash) (Set.toList received) ] - toObject _ (PPViewHashesDontMatch ppHashInTxBody ppHashFromPParams) = + toObject _ (PPViewHashesDontMatch Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "PPViewHashesDontMatch" - , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe ppHashInTxBody) - , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe ppHashFromPParams) + , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) + , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) ] toObject _ (MissingRequiredSigners missingKeyWitnesses) = mconcat [ "kind" .= String "MissingRequiredSigners" @@ -551,10 +551,10 @@ instance , "badInputs" .= badInputs , "error" .= renderBadInputsUTxOErr badInputs ] - toObject _verb (ExpiredUTxO ttl slot) = + toObject _verb (ExpiredUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ExpiredUTxO" - , "ttl" .= ttl - , "slot" .= slot ] + , "ttl" .= mismatchSupplied + , "slot" .= mismatchExpected ] toObject _verb (MaxTxSizeUTxO (Mismatch { mismatchSupplied = txsize , mismatchExpected = maxtxsize })) = mconcat [ "kind" .= String "MaxTxSizeUTxO" @@ -583,11 +583,11 @@ instance mconcat [ "kind" .= String "FeeTooSmallUTxO" , "minimum" .= minfee , "fee" .= txfee ] - toObject _verb (ValueNotConservedUTxO consumed produced) = + toObject _verb (ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= consumed - , "produced" .= produced - , "error" .= renderValueNotConservedErr consumed produced + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected ] toObject verb (UpdateFailure f) = toObject verb f @@ -618,21 +618,21 @@ instance mconcat [ "kind" .= String "ExpiredUTxO" , "validityInterval" .= validityInterval , "slot" .= slot ] - toObject _verb (Allegra.MaxTxSizeUTxO txsize maxtxsize) = + toObject _verb (Allegra.MaxTxSizeUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= txsize - , "maxSize" .= maxtxsize ] + , "size" .= mismatchSupplied + , "maxSize" .= mismatchExpected ] toObject _verb Allegra.InputSetEmptyUTxO = mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - toObject _verb (Allegra.FeeTooSmallUTxO minfee txfee) = + toObject _verb (Allegra.FeeTooSmallUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= minfee - , "fee" .= txfee ] - toObject _verb (Allegra.ValueNotConservedUTxO consumed produced) = + , "minimum" .= mismatchExpected + , "fee" .= mismatchSupplied ] + toObject _verb (Allegra.ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= consumed - , "produced" .= produced - , "error" .= renderValueNotConservedErr consumed produced + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected ] toObject _verb (Allegra.WrongNetwork network addrs) = mconcat [ "kind" .= String "WrongNetwork" @@ -723,11 +723,6 @@ instance Ledger.Era era => ToObject (ShelleyDelegPredFailure era) where , "credential" .= String (textShow alreadyRegistered) , "error" .= String "Staking credential already registered" ] - toObject _verb (StakeKeyInRewardsDELEG alreadyRegistered) = - mconcat [ "kind" .= String "StakeKeyInRewardsDELEG" - , "credential" .= String (textShow alreadyRegistered) - , "error" .= String "Staking credential registered in rewards map" - ] toObject _verb (StakeKeyNotRegisteredDELEG notRegistered) = mconcat [ "kind" .= String "StakeKeyNotRegisteredDELEG" , "credential" .= String (textShow notRegistered) @@ -754,18 +749,18 @@ instance Ledger.Era era => ToObject (ShelleyDelegPredFailure era) where , "duplicateKeyHash" .= String (textShow genesisKeyHash) , "error" .= String "This genesis key has already been delegated to" ] - toObject _verb (InsufficientForInstantaneousRewardsDELEG mirpot neededMirAmount reserves) = + toObject _verb (InsufficientForInstantaneousRewardsDELEG mirpot Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "InsufficientForInstantaneousRewardsDELEG" , "pot" .= String (case mirpot of ReservesMIR -> "Reserves" TreasuryMIR -> "Treasury") - , "neededAmount" .= neededMirAmount - , "reserves" .= reserves + , "neededAmount" .= mismatchSupplied + , "reserves" .= mismatchExpected ] - toObject _verb (MIRCertificateTooLateinEpochDELEG currSlot boundSlotNo) = + toObject _verb (MIRCertificateTooLateinEpochDELEG Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "MIRCertificateTooLateinEpochDELEG" - , "currentSlotNo" .= currSlot - , "mustBeSubmittedBeforeSlotNo" .= boundSlotNo + , "currentSlotNo" .= mismatchSupplied + , "mustBeSubmittedBeforeSlotNo" .= mismatchExpected ] toObject _verb (DuplicateGenesisVRFDELEG vrfKeyHash) = mconcat [ "kind" .= String "DuplicateGenesisVRFDELEG" @@ -777,13 +772,13 @@ instance Ledger.Era era => ToObject (ShelleyDelegPredFailure era) where toObject _verb MIRNegativesNotCurrentlyAllowed = mconcat [ "kind" .= String "MIRNegativesNotCurrentlyAllowed" ] - toObject _verb (InsufficientForTransferDELEG mirpot attempted available) = + toObject _verb (InsufficientForTransferDELEG mirpot Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "DuplicateGenesisVRFDELEG" , "pot" .= String (case mirpot of ReservesMIR -> "Reserves" TreasuryMIR -> "Treasury") - , "attempted" .= attempted - , "available" .= available + , "attempted" .= mismatchSupplied + , "available" .= mismatchExpected ] toObject _verb MIRProducesNegativeUpdate = mconcat [ "kind" .= String "MIRProducesNegativeUpdate" @@ -1071,23 +1066,23 @@ instance , "validityInterval" .= validtyInterval , "slot" .= slot ] - toObject _verb (Alonzo.MaxTxSizeUTxO txsize maxtxsize) = + toObject _verb (Alonzo.MaxTxSizeUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= txsize - , "maxSize" .= maxtxsize + , "size" .= mismatchSupplied + , "maxSize" .= mismatchExpected ] toObject _verb Alonzo.InputSetEmptyUTxO = mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - toObject _verb (Alonzo.FeeTooSmallUTxO minfee currentFee) = + toObject _verb (Alonzo.FeeTooSmallUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= minfee - , "fee" .= currentFee + , "minimum" .= mismatchExpected + , "fee" .= mismatchSupplied ] - toObject _verb (Alonzo.ValueNotConservedUTxO consumed produced) = + toObject _verb (Alonzo.ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= consumed - , "produced" .= produced - , "error" .= renderValueNotConservedErr consumed produced + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected ] toObject _verb (Alonzo.WrongNetwork network addrs) = mconcat [ "kind" .= String "WrongNetwork" @@ -1132,28 +1127,28 @@ instance mconcat [ "kind" .= String "ScriptsNotPaidUTxO" , "utxos" .= utxos ] - toObject _verb (Alonzo.ExUnitsTooBigUTxO pParamsMaxExUnits suppliedExUnits) = + toObject _verb (Alonzo.ExUnitsTooBigUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ExUnitsTooBigUTxO" - , "maxexunits" .= pParamsMaxExUnits - , "exunits" .= suppliedExUnits + , "maxexunits" .= mismatchExpected + , "exunits" .= mismatchSupplied ] toObject _verb (Alonzo.CollateralContainsNonADA inputs) = mconcat [ "kind" .= String "CollateralContainsNonADA" , "inputs" .= inputs ] - toObject _verb (Alonzo.WrongNetworkInTxBody actualNetworkId netIdInTxBody) = + toObject _verb (Alonzo.WrongNetworkInTxBody Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "WrongNetworkInTxBody" - , "networkid" .= actualNetworkId - , "txbodyNetworkId" .= netIdInTxBody + , "networkid" .= mismatchExpected + , "txbodyNetworkId" .= mismatchSupplied ] toObject _verb (Alonzo.OutsideForecast slotNum) = mconcat [ "kind" .= String "OutsideForecast" , "slot" .= slotNum ] - toObject _verb (Alonzo.TooManyCollateralInputs maxCollateralInputs numberCollateralInputs) = + toObject _verb (Alonzo.TooManyCollateralInputs Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "TooManyCollateralInputs" - , "max" .= maxCollateralInputs - , "inputs" .= numberCollateralInputs + , "max" .= mismatchExpected + , "inputs" .= mismatchSupplied ] toObject _verb Alonzo.NoCollateralInputs = mconcat [ "kind" .= String "NoCollateralInputs" ] @@ -1294,11 +1289,12 @@ instance Core.Crypto crypto => ToObject (Praos.PraosValidationErr crypto) where , "opCertStartingKesPeriod" .= oCertStartKesPeriod , "error" .= err ] - Praos.InvalidKesSignatureOCERT currentKesPeriod opCertStartKesPeriod expectedKesEvos err -> + Praos.InvalidKesSignatureOCERT currentKesPeriod opCertStartKesPeriod expectedKesEvos maxKesEvos err -> mconcat [ "kind" .= String "InvalidKesSignatureOCERT" , "currentKesPeriod" .= currentKesPeriod , "opCertStartingKesPeriod" .= opCertStartKesPeriod , "expectedKesEvolutions" .= expectedKesEvos + , "maximumKesEvolutions" .= maxKesEvos , "error" .= err ] Praos.NoCounterForKeyHashOCERT stakePoolKeyHash-> @@ -1346,6 +1342,7 @@ instance ToJSON ShelleyNodeToClientVersion where toJSON ShelleyNodeToClientVersion8 = String "ShelleyNodeToClientVersion8" toJSON ShelleyNodeToClientVersion9 = String "ShelleyNodeToClientVersion9" toJSON ShelleyNodeToClientVersion10 = String "ShelleyNodeToClientVersion10" + toJSON ShelleyNodeToClientVersion11 = String "ShelleyNodeToClientVersion11" instance Ledger.Crypto c => ToObject (PraosChainSelectView c) where toObject _ PraosChainSelectView { @@ -1416,23 +1413,23 @@ instance , "validityInterval" .= validityInterval , "slot" .= slot ] - Conway.MaxTxSizeUTxO txsize maxtxsize -> + Conway.MaxTxSizeUTxO Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= txsize - , "maxSize" .= maxtxsize + , "size" .= mismatchSupplied + , "maxSize" .= mismatchExpected ] Conway.InputSetEmptyUTxO -> mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - Conway.FeeTooSmallUTxO minfee txfee -> + Conway.FeeTooSmallUTxO Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= minfee - , "fee" .= txfee + , "minimum" .= mismatchExpected + , "fee" .= mismatchSupplied ] - Conway.ValueNotConservedUTxO consumed produced -> + Conway.ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= consumed - , "produced" .= produced - , "error" .= renderValueNotConservedErr consumed produced + , "consumed" .= mismatchSupplied + , "produced" .= mismatchExpected + , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected ] Conway.WrongNetwork network addrs -> mconcat [ "kind" .= String "WrongNetwork" @@ -1473,28 +1470,28 @@ instance mconcat [ "kind" .= String "ScriptsNotPaidUTxO" , "utxos" .= utxos ] - Conway.ExUnitsTooBigUTxO pParamsMaxExUnits suppliedExUnits -> + Conway.ExUnitsTooBigUTxO Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "ExUnitsTooBigUTxO" - , "maxexunits" .= pParamsMaxExUnits - , "exunits" .= suppliedExUnits + , "maxexunits" .= mismatchExpected + , "exunits" .= mismatchSupplied ] Conway.CollateralContainsNonADA inputs -> mconcat [ "kind" .= String "CollateralContainsNonADA" , "inputs" .= inputs ] - Conway.WrongNetworkInTxBody actualNetworkId netIdInTxBody -> + Conway.WrongNetworkInTxBody Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "WrongNetworkInTxBody" - , "networkid" .= actualNetworkId - , "txbodyNetworkId" .= netIdInTxBody + , "networkid" .= mismatchExpected + , "txbodyNetworkId" .= mismatchSupplied ] Conway.OutsideForecast slotNum -> mconcat [ "kind" .= String "OutsideForecast" , "slot" .= slotNum ] - Conway.TooManyCollateralInputs maxCollateralInputs numberCollateralInputs -> + Conway.TooManyCollateralInputs Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "TooManyCollateralInputs" - , "max" .= maxCollateralInputs - , "inputs" .= numberCollateralInputs + , "max" .= mismatchExpected + , "inputs" .= mismatchSupplied ] Conway.NoCollateralInputs -> mconcat [ "kind" .= String "NoCollateralInputs" ] @@ -1548,10 +1545,10 @@ instance mconcat [ "kind" .= String "MissingTxMetadata" , "txBodyMetadataHash" .= hash ] - Conway.ConflictingMetadataHash txBodyMetadataHash fullMetadataHash -> + Conway.ConflictingMetadataHash Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "ConflictingMetadataHash" - , "txBodyMetadataHash" .= txBodyMetadataHash - , "fullMetadataHash" .= fullMetadataHash + , "txBodyMetadataHash" .= mismatchSupplied + , "fullMetadataHash" .= mismatchExpected ] Conway.InvalidMetadata -> mconcat [ "kind" .= String "InvalidMetadata" @@ -1576,10 +1573,10 @@ instance , "disallowed" .= Set.toList disallowed , "acceptable" .= Set.toList acceptable ] - Conway.PPViewHashesDontMatch ppHashInTxBody ppHashFromPParams -> + Conway.PPViewHashesDontMatch Mismatch {mismatchSupplied, mismatchExpected} -> mconcat [ "kind" .= String "PPViewHashesDontMatch" - , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe ppHashInTxBody) - , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe ppHashFromPParams) + , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) + , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) ] Conway.UnspendableUTxONoDatumHash ins -> mconcat [ "kind" .= String "MissingRequiredSigners" diff --git a/cardano-node/src/Cardano/Tracing/Peer.hs b/cardano-node/src/Cardano/Tracing/Peer.hs index 6366a0d8be7..d7caff501b0 100644 --- a/cardano-node/src/Cardano/Tracing/Peer.hs +++ b/cardano-node/src/Cardano/Tracing/Peer.hs @@ -18,8 +18,7 @@ import Cardano.Node.Orphans () import Cardano.Node.Queries import Ouroboros.Consensus.Block (Header) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientHandle, - csCandidate, viewChainSyncState) -import Ouroboros.Consensus.Util.NormalForm.StrictTVar (StrictTVar) + csCandidate, cschcMap, viewChainSyncState) import Ouroboros.Consensus.Util.Orphans () import qualified Ouroboros.Network.AnchoredFragment as Net import Ouroboros.Network.Block (unSlotNo) @@ -97,7 +96,7 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd tuple3pop (a, b, _) = (a, b) getCandidates - :: StrictTVar IO (Map peer (ChainSyncClientHandle IO blk)) + :: STM.STM IO (Map peer (ChainSyncClientHandle IO blk)) -> STM.STM IO (Map peer (Net.AnchoredFragment (Header blk))) getCandidates handle = viewChainSyncState handle csCandidate @@ -109,7 +108,7 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd . Net.readFetchClientsStateVars . getFetchClientRegistry $ kernel ) - candidates <- STM.atomically . getCandidates . getChainSyncHandles $ kernel + candidates <- STM.atomically . getCandidates . cschcMap . getChainSyncHandles $ kernel let peers = flip Map.mapMaybeWithKey candidates $ \cid af -> maybe Nothing diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 78ea014e3e5..edcdfab451c 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -57,6 +57,7 @@ import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (. import Cardano.Tracing.Config import Cardano.Tracing.HasIssuer (BlockIssuerVerificationKeyHash (..), HasIssuer (..)) import Cardano.Tracing.Metrics +import Cardano.Tracing.OrphanInstances.Network () import Cardano.Tracing.Render (renderChainHash, renderHeaderHash) import Cardano.Tracing.Shutdown () import Cardano.Tracing.Startup () @@ -69,7 +70,7 @@ import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) import Ouroboros.Consensus.Ledger.Abstract (LedgerErr, LedgerState) import Ouroboros.Consensus.Ledger.Extended (ledgerState) import Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent) -import Ouroboros.Consensus.Ledger.Query (BlockQuery) +import Ouroboros.Consensus.Ledger.Query (BlockQuery, Query) import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, GenTxId, HasTxs, LedgerSupportsMempool, ByteSize32 (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) @@ -92,21 +93,24 @@ import Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), HasHea import Ouroboros.Network.BlockFetch.ClientState (TraceFetchClientState (..), TraceLabelPeer (..)) import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline (..)) +import Ouroboros.Network.BlockFetch.Decision.Trace import Ouroboros.Network.ConnectionId (ConnectionId) -import Ouroboros.Network.ConnectionManager.Types (ConnectionManagerCounters (..), - ConnectionManagerTrace (..)) +import qualified Ouroboros.Network.ConnectionManager.Core as ConnectionManager +import Ouroboros.Network.ConnectionManager.Types (ConnectionManagerCounters (..)) import qualified Ouroboros.Network.Diffusion as Diffusion import qualified Ouroboros.Network.Diffusion.NonP2P as NonP2P import qualified Ouroboros.Network.Diffusion.P2P as P2P -import Ouroboros.Network.InboundGovernor (InboundGovernorTrace (..)) -import Ouroboros.Network.InboundGovernor.State (InboundGovernorCounters (..)) +import qualified Ouroboros.Network.Driver.Stateful as Stateful +import qualified Ouroboros.Network.InboundGovernor as InboundGovernor +import Ouroboros.Network.InboundGovernor.State as InboundGovernor import Ouroboros.Network.NodeToClient (LocalAddress) import Ouroboros.Network.NodeToNode (RemoteAddress) import Ouroboros.Network.PeerSelection.Governor (ChurnCounters (..), PeerSelectionCounters, PeerSelectionView (..)) import qualified Ouroboros.Network.PeerSelection.Governor as Governor import Ouroboros.Network.Point (fromWithOrigin) -import Ouroboros.Network.Protocol.LocalStateQuery.Type (ShowQuery) +import Ouroboros.Network.Protocol.LocalStateQuery.Type (LocalStateQuery, ShowQuery) +import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery import Ouroboros.Network.TxSubmission.Inbound import Codec.CBOR.Read (DeserialiseFailure) @@ -135,7 +139,7 @@ import GHC.TypeLits (KnownNat, Nat, natVal) import qualified System.Metrics.Counter as Counter import qualified System.Metrics.Gauge as Gauge import qualified System.Metrics.Label as Label -import qualified System.Remote.Monitoring as EKG +import qualified System.Remote.Monitoring.Wai as EKG {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -245,12 +249,10 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where doelide (WithSeverity _ (ChainDB.TraceGCEvent _)) = True doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreBlockOlderThanK _))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreInvalidBlock _ _))) = False - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.BlockInTheFuture _ _))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.StoreButDontChange _))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.TrySwitchToAFork _ _))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.SwitchedToAFork{}))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation (ChainDB.InvalidBlock _ _)))) = False - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation ChainDB.CandidateContainsFutureBlocksExceedingClockSkew{}))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation _))) = True doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.AddedToCurrentChain events _ _ _))) = null events doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.PipeliningEvent{}))) = True @@ -511,6 +513,7 @@ mkTracers _ _ _ _ _ enableP2P = , Consensus.blockchainTimeTracer = nullTracer , Consensus.consensusErrorTracer = nullTracer , Consensus.gsmTracer = nullTracer + , Consensus.csjTracer = nullTracer } , nodeToClientTracers = NodeToClient.Tracers { NodeToClient.tChainSyncTracer = nullTracer @@ -524,6 +527,7 @@ mkTracers _ _ _ _ _ enableP2P = , NodeToNode.tBlockFetchTracer = nullTracer , NodeToNode.tBlockFetchSerialisedTracer = nullTracer , NodeToNode.tTxSubmission2Tracer = nullTracer + , NodeToNode.tKeepAliveTracer = nullTracer } , diffusionTracers = Diffusion.nullTracers , diffusionTracersExtra = @@ -721,6 +725,8 @@ mkConsensusTracers :: forall blk peer localPeer. ( Show peer , Eq peer + , ToObject peer + , ToJSON peer , LedgerQueries blk , ToJSON (GenTxId blk) , ToObject (ApplyTxErr blk) @@ -730,7 +736,6 @@ mkConsensusTracers , ToObject (OtherHeaderEnvelopeError blk) , ToObject (ValidationErr (BlockProtocol blk)) , ToObject (ForgeStateUpdateError blk) - , ToObject peer , Consensus.RunNode blk , HasKESMetricsData blk , HasKESInfo blk @@ -811,6 +816,7 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do , Consensus.consensusErrorTracer = Tracer $ \err -> traceWith (toLogObject tr) (ConsensusStartupException err) , Consensus.gsmTracer = tracerOnOff (traceGsm trSel) verb "GSM" tr + , Consensus.csjTracer = tracerOnOff (traceCsj trSel) verb "CSJ" tr } where mkForgeTracers :: IO ForgeTracers @@ -1387,8 +1393,12 @@ forgeStateInfoTracer p _ts tracer = Tracer $ \ev -> do -------------------------------------------------------------------------------- nodeToClientTracers' - :: ( ToObject localPeer + :: forall blk localPeer. + ( HasPrivacyAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) + , HasSeverityAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) + , ToObject (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) , ShowQuery (BlockQuery blk) + , ToObject localPeer ) => TraceSelection -> TracingVerbosity @@ -1442,22 +1452,30 @@ nodeToNodeTracers' trSel verb tr = , NodeToNode.tTxSubmission2Tracer = tracerOnOff (traceTxSubmissionProtocol trSel) verb "TxSubmissionProtocol" tr + , NodeToNode.tKeepAliveTracer = + tracerOnOff (traceKeepAliveProtocol trSel) + verb "KeepAliveProtocol" tr } +-- TODO @ouroboros-network teeTraceBlockFetchDecision :: ( Eq peer - , HasHeader blk , Show peer - , ToObject peer + , ToJSON peer + , HasHeader blk + , ConvertRawHash blk ) => TracingVerbosity -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer) -> Trace IO Text - -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]) + -> Tracer IO (WithSeverity (TraceDecisionEvent peer (Header blk))) teeTraceBlockFetchDecision verb eliding tr = - Tracer $ \ev -> do - traceWith (teeTraceBlockFetchDecision' meTr) ev - traceWith (teeTraceBlockFetchDecisionElide verb eliding bfdTr) ev + Tracer $ \(WithSeverity s ev) -> case ev of + PeerStarvedUs {} -> do + traceWith (toLogObject' verb meTr) ev + PeersFetch ev' -> do + traceWith (teeTraceBlockFetchDecision' meTr) (WithSeverity s ev') + traceWith (teeTraceBlockFetchDecisionElide verb eliding bfdTr) (WithSeverity s ev') where meTr = appendName "metrics" tr bfdTr = appendName "BlockFetchDecision" tr @@ -1473,9 +1491,10 @@ teeTraceBlockFetchDecision' tr = teeTraceBlockFetchDecisionElide :: ( Eq peer - , HasHeader blk , Show peer - , ToObject peer + , ToJSON peer + , HasHeader blk + , ConvertRawHash blk ) => TracingVerbosity -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer) @@ -1490,14 +1509,14 @@ teeTraceBlockFetchDecisionElide = elideToLogObject traceConnectionManagerTraceMetrics :: OnOff TraceConnectionManagerCounters -> Maybe EKGDirect - -> Tracer IO (ConnectionManagerTrace peerAddr handlerTrace) + -> Tracer IO (ConnectionManager.Trace peerAddr handlerTrace) traceConnectionManagerTraceMetrics _ Nothing = nullTracer traceConnectionManagerTraceMetrics (OnOff False) _ = nullTracer traceConnectionManagerTraceMetrics (OnOff True) (Just ekgDirect) = cmtTracer where - cmtTracer :: Tracer IO (ConnectionManagerTrace peerAddr handlerTrace) + cmtTracer :: Tracer IO (ConnectionManager.Trace peerAddr handlerTrace) cmtTracer = Tracer $ \case - (TrConnectionManagerCounters + (ConnectionManager.TrConnectionManagerCounters (ConnectionManagerCounters prunableConns duplexConns @@ -1621,14 +1640,14 @@ traceInboundGovernorCountersMetrics :: forall addr. OnOff TraceInboundGovernorCounters -> Maybe EKGDirect - -> Tracer IO (InboundGovernorTrace addr) + -> Tracer IO (InboundGovernor.Trace addr) traceInboundGovernorCountersMetrics _ Nothing = nullTracer traceInboundGovernorCountersMetrics (OnOff False) _ = nullTracer traceInboundGovernorCountersMetrics (OnOff True) (Just ekgDirect) = ipgcTracer where - ipgcTracer :: Tracer IO (InboundGovernorTrace addr) + ipgcTracer :: Tracer IO (InboundGovernor.Trace addr) ipgcTracer = Tracer $ \case - (TrInboundGovernorCounters InboundGovernorCounters { + (InboundGovernor.TrInboundGovernorCounters InboundGovernor.Counters { idlePeersRemote, coldPeersRemote, warmPeersRemote, diff --git a/cardano-node/test/Test/Cardano/Node/Gen.hs b/cardano-node/test/Test/Cardano/Node/Gen.hs index f7851a7aca0..b2d6048403d 100644 --- a/cardano-node/test/Test/Cardano/Node/Gen.hs +++ b/cardano-node/test/Test/Cardano/Node/Gen.hs @@ -25,7 +25,9 @@ import Cardano.Node.Configuration.NodeAddress (NodeAddress' (..), Node import Cardano.Node.Configuration.TopologyP2P (LocalRootPeersGroup (..), LocalRootPeersGroups (..), NetworkTopology (..), NodeSetup (..), PeerAdvertise (..), PublicRootPeers (..), RootConfig (..)) +import Cardano.Node.Types import Cardano.Slotting.Slot (SlotNo (..)) +import Ouroboros.Network.NodeToNode.Version import Ouroboros.Network.PeerSelection.Bootstrap import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..), UseLedgerPeers (..)) @@ -55,6 +57,7 @@ genNetworkTopology = <*> Gen.list (Range.linear 0 10) genPublicRootPeers <*> genUseLedgerPeers <*> genUseBootstrapPeers + <*> genPeerSnapshotPath ] -- | Generate valid encodings of p2p topology files @@ -180,7 +183,7 @@ genLocalRootPeersGroup = do ra <- genRootConfig hval <- Gen.int (Range.linear 0 (length (rootAccessPoints ra))) wval <- WarmValency <$> Gen.int (Range.linear 0 hval) - LocalRootPeersGroup ra (HotValency hval) wval <$> genPeerTrustable + LocalRootPeersGroup ra (HotValency hval) wval <$> genPeerTrustable <*> pure InitiatorAndResponderDiffusionMode genLocalRootPeersGroups :: Gen LocalRootPeersGroups genLocalRootPeersGroups = @@ -205,5 +208,12 @@ genUseBootstrapPeers = do domains <- Gen.list (Range.linear 0 6) genRelayAddress Gen.element [ DontUseBootstrapPeers , UseBootstrapPeers domains ] +genPeerSnapshotPath :: Gen (Maybe PeerSnapshotFile) +genPeerSnapshotPath = + Gen.element + [ Nothing + , Just . PeerSnapshotFile $ "dummy" + ] + genPeerTrustable :: Gen PeerTrustable genPeerTrustable = Gen.element [ IsNotTrustable, IsTrustable ] diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index 2b2c416d704..9e7a7f84bc0 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} module Test.Cardano.Node.POM @@ -15,11 +16,9 @@ import Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartia import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (NumOfDiskSnapshots (..), - SnapshotInterval (..)) + SnapshotInterval (..), pattern DoDiskSnapshotChecksum) import Ouroboros.Network.Block (SlotNo (..)) -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), - DiffusionMode (InitiatorAndResponderDiffusionMode)) -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.Diffusion.Configuration import Data.Monoid (Last (..)) import Data.Text (Text) @@ -119,6 +118,7 @@ testPartialYamlConfig = , pncDiffusionMode = Last Nothing , pncNumOfDiskSnapshots = Last Nothing , pncSnapshotInterval = mempty + , pncDoDiskSnapshotChecksum = Last . Just $ DoDiskSnapshotChecksum , pncExperimentalProtocolsEnabled = Last Nothing , pncMaxConcurrencyBulkSync = Last Nothing , pncMaxConcurrencyDeadline = Last Nothing @@ -136,15 +136,21 @@ testPartialYamlConfig = , pncTimeWaitTimeout = mempty , pncChainSyncIdleTimeout = mempty , pncAcceptedConnectionsLimit = mempty - , pncTargetNumberOfRootPeers = mempty - , pncTargetNumberOfKnownPeers = mempty - , pncTargetNumberOfEstablishedPeers = mempty - , pncTargetNumberOfActivePeers = mempty - , pncTargetNumberOfKnownBigLedgerPeers = mempty - , pncTargetNumberOfEstablishedBigLedgerPeers = mempty - , pncTargetNumberOfActiveBigLedgerPeers = mempty + , pncDeadlineTargetOfRootPeers = mempty + , pncDeadlineTargetOfKnownPeers = mempty + , pncDeadlineTargetOfEstablishedPeers = mempty + , pncDeadlineTargetOfActivePeers = mempty + , pncDeadlineTargetOfKnownBigLedgerPeers = mempty + , pncDeadlineTargetOfEstablishedBigLedgerPeers = mempty + , pncDeadlineTargetOfActiveBigLedgerPeers = mempty + , pncSyncTargetOfActivePeers = mempty + , pncSyncTargetOfKnownBigLedgerPeers = mempty + , pncSyncTargetOfEstablishedBigLedgerPeers = mempty + , pncSyncTargetOfActiveBigLedgerPeers = mempty + , pncMinBigLedgerPeersForTrustedState = mempty , pncEnableP2P = Last (Just DisabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) + , pncConsensusMode = mempty } -- | Example partial configuration theoretically created @@ -161,6 +167,7 @@ testPartialCliConfig = , pncDiffusionMode = mempty , pncNumOfDiskSnapshots = Last Nothing , pncSnapshotInterval = Last . Just . RequestedSnapshotInterval $ secondsToDiffTime 100 + , pncDoDiskSnapshotChecksum = Last . Just $ DoDiskSnapshotChecksum , pncExperimentalProtocolsEnabled = Last $ Just True , pncProtocolFiles = Last . Just $ ProtocolFilepaths Nothing Nothing Nothing Nothing Nothing Nothing , pncValidateDB = Last $ Just True @@ -176,15 +183,21 @@ testPartialCliConfig = , pncTimeWaitTimeout = mempty , pncChainSyncIdleTimeout = mempty , pncAcceptedConnectionsLimit = mempty - , pncTargetNumberOfRootPeers = mempty - , pncTargetNumberOfKnownPeers = mempty - , pncTargetNumberOfEstablishedPeers = mempty - , pncTargetNumberOfActivePeers = mempty - , pncTargetNumberOfKnownBigLedgerPeers = mempty - , pncTargetNumberOfEstablishedBigLedgerPeers = mempty - , pncTargetNumberOfActiveBigLedgerPeers = mempty + , pncDeadlineTargetOfRootPeers = mempty + , pncDeadlineTargetOfKnownPeers = mempty + , pncDeadlineTargetOfEstablishedPeers = mempty + , pncDeadlineTargetOfActivePeers = mempty + , pncDeadlineTargetOfKnownBigLedgerPeers = mempty + , pncDeadlineTargetOfEstablishedBigLedgerPeers = mempty + , pncDeadlineTargetOfActiveBigLedgerPeers = mempty + , pncSyncTargetOfActivePeers = mempty + , pncSyncTargetOfKnownBigLedgerPeers = mempty + , pncSyncTargetOfEstablishedBigLedgerPeers = mempty + , pncSyncTargetOfActiveBigLedgerPeers = mempty + , pncMinBigLedgerPeersForTrustedState = Last (Just defaultMinBigLedgerPeersForTrustedState) , pncEnableP2P = Last (Just DisabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) + , pncConsensusMode = Last (Just PraosMode) } -- | Expected final NodeConfiguration @@ -205,6 +218,7 @@ eExpectedConfig = do , ncDiffusionMode = InitiatorAndResponderDiffusionMode , ncNumOfDiskSnapshots = DefaultNumOfDiskSnapshots , ncSnapshotInterval = RequestedSnapshotInterval $ secondsToDiffTime 100 + , ncDoDiskSnapshotChecksum = DoDiskSnapshotChecksum , ncExperimentalProtocolsEnabled = True , ncMaxConcurrencyBulkSync = Nothing , ncMaxConcurrencyDeadline = Nothing @@ -222,15 +236,21 @@ eExpectedConfig = do , acceptedConnectionsSoftLimit = 384 , acceptedConnectionsDelay = 5 } - , ncTargetNumberOfRootPeers = 85 - , ncTargetNumberOfKnownPeers = 85 - , ncTargetNumberOfEstablishedPeers = 40 - , ncTargetNumberOfActivePeers = 15 - , ncTargetNumberOfKnownBigLedgerPeers = 15 - , ncTargetNumberOfEstablishedBigLedgerPeers = 10 - , ncTargetNumberOfActiveBigLedgerPeers = 5 + , ncDeadlineTargetOfRootPeers = 60 + , ncDeadlineTargetOfKnownPeers = 85 + , ncDeadlineTargetOfEstablishedPeers = 40 + , ncDeadlineTargetOfActivePeers = 15 + , ncDeadlineTargetOfKnownBigLedgerPeers = 15 + , ncDeadlineTargetOfEstablishedBigLedgerPeers = 10 + , ncDeadlineTargetOfActiveBigLedgerPeers = 5 + , ncSyncTargetOfActivePeers = 0 + , ncSyncTargetOfKnownBigLedgerPeers = 100 + , ncSyncTargetOfEstablishedBigLedgerPeers = 50 + , ncSyncTargetOfActiveBigLedgerPeers = 30 + , ncMinBigLedgerPeersForTrustedState = defaultMinBigLedgerPeersForTrustedState , ncEnableP2P = SomeNetworkP2PMode Consensus.DisabledP2PMode , ncPeerSharing = PeerSharingDisabled + , ncConsensusMode = PraosMode } -- ----------------------------------------------------------------------------- diff --git a/cardano-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index c5032f24142..e8960b63403 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -39,7 +39,7 @@ library , aeson , async , bytestring - , cardano-api ^>= 10.1 + , cardano-api ^>= 10.4 , cardano-binary , cardano-cli ^>= 10.1 , cardano-crypto-class ^>= 2.1.2 @@ -49,7 +49,7 @@ library , network , optparse-applicative-fork , ouroboros-consensus-cardano - , ouroboros-network ^>= 0.17 + , ouroboros-network ^>= 0.18 , ouroboros-network-protocols , prometheus >= 2.2.4 , servant diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index 65dc8812e7e..691572af155 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -35,7 +35,7 @@ library , aeson-pretty , ansi-terminal , bytestring - , cardano-api ^>= 10.1 + , cardano-api ^>= 10.4 , cardano-cli ^>= 10.1 , cardano-crypto-class , cardano-crypto-wrapper @@ -49,7 +49,7 @@ library , cardano-ledger-core:{cardano-ledger-core, testlib} , cardano-ledger-shelley , cardano-node - , cardano-ping ^>= 0.5 + , cardano-ping ^>= 0.6 , contra-tracer , containers , data-default-class @@ -62,7 +62,7 @@ library , exceptions , filepath , hedgehog - , hedgehog-extras ^>= 0.6.4 + , hedgehog-extras >= 0.6.4 && <0.6.5.1 , lens-aeson , microlens , mono-traversable @@ -70,7 +70,7 @@ library , network , network-mux , optparse-applicative-fork - , ouroboros-network ^>= 0.17 + , ouroboros-network ^>= 0.18 , ouroboros-network-api , prettyprinter , process diff --git a/cardano-testnet/src/Testnet/Components/Configuration.hs b/cardano-testnet/src/Testnet/Components/Configuration.hs index 86b80aed801..5cf18b357d2 100644 --- a/cardano-testnet/src/Testnet/Components/Configuration.hs +++ b/cardano-testnet/src/Testnet/Components/Configuration.hs @@ -27,6 +27,7 @@ import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis) import Cardano.Ledger.Conway.Genesis (ConwayGenesis) import qualified Cardano.Node.Configuration.Topology as NonP2P import qualified Cardano.Node.Configuration.TopologyP2P as P2P +import Ouroboros.Network.NodeToNode (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.Bootstrap import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.PeerTrustable @@ -72,7 +73,7 @@ createConfigJson :: () -> ShelleyBasedEra era -- ^ The era used for generating the hard fork configuration toggle -> m LBS.ByteString createConfigJson (TmpAbsolutePath tempAbsPath) sbe = GHC.withFrozenCallStack $ do - byronGenesisHash <- getByronGenesisHash $ tempAbsPath "byron/genesis.json" + byronGenesisHash <- getByronGenesisHash $ tempAbsPath "byron-genesis.json" shelleyGenesisHash <- getHash ShelleyEra "ShelleyGenesisHash" alonzoGenesisHash <- getHash AlonzoEra "AlonzoGenesisHash" conwayGenesisHash <- getHash ConwayEra "ConwayGenesisHash" @@ -125,7 +126,7 @@ createSPOGenesisAndFiles -> ConwayGenesis StandardCrypto -- ^ The conway genesis to use, for example 'Defaults.defaultConwayGenesis'. -> TmpAbsolutePath -> m FilePath -- ^ Shelley genesis directory -createSPOGenesisAndFiles nPoolNodes nDelReps maxSupply sbe shelleyGenesis +createSPOGenesisAndFiles nPoolNodes nDelReps maxSupply asbe@(AnyShelleyBasedEra sbe) shelleyGenesis alonzoGenesis conwayGenesis (TmpAbsolutePath tempAbsPath) = GHC.withFrozenCallStack $ do let inputGenesisShelleyFp = tempAbsPath genesisInputFilepath ShelleyEra inputGenesisAlonzoFp = tempAbsPath genesisInputFilepath AlonzoEra @@ -161,8 +162,10 @@ createSPOGenesisAndFiles nPoolNodes nDelReps maxSupply sbe shelleyGenesis H.note_ $ "Number of stake delegators: " <> show nPoolNodes H.note_ $ "Number of seeded UTxO keys: " <> show numSeededUTxOKeys - execCli_ - [ anyShelleyBasedEraToString sbe, "genesis", "create-testnet-data" + let eraString = anyShelleyBasedEraToString asbe + era = toCardanoEra sbe + execCli_ $ + [ eraString, "genesis", "create-testnet-data" , "--spec-shelley", inputGenesisShelleyFp , "--spec-alonzo", inputGenesisAlonzoFp , "--spec-conway", inputGenesisConwayFp @@ -170,23 +173,18 @@ createSPOGenesisAndFiles nPoolNodes nDelReps maxSupply sbe shelleyGenesis , "--pools", show nPoolNodes , "--total-supply", show maxSupply -- Half of this will be delegated, see https://github.com/IntersectMBO/cardano-cli/pull/874 , "--stake-delegators", show numStakeDelegators - , "--utxo-keys", show numSeededUTxOKeys - , "--drep-keys", show nDelReps - , "--start-time", DTC.formatIso8601 startTime + , "--utxo-keys", show numSeededUTxOKeys] + <> monoidForEraInEon @ConwayEraOnwards era (const ["--drep-keys", show nDelReps]) + <> [ "--start-time", DTC.formatIso8601 startTime , "--out-dir", tempAbsPath ] -- Remove the input files. We don't need them anymore, since create-testnet-data wrote new versions. forM_ [inputGenesisShelleyFp, inputGenesisAlonzoFp, inputGenesisConwayFp] (liftIO . System.removeFile) - -- Move all genesis related files - genesisByronDir <- H.createDirectoryIfMissing $ tempAbsPath "byron" - files <- H.listDirectory tempAbsPath forM_ files H.note - H.renameFile (tempAbsPath "byron-gen-command" "genesis.json") (genesisByronDir "genesis.json") - return genesisShelleyDir where genesisInputFilepath e = "genesis-input." <> anyEraToString (AnyCardanoEra e) <> ".json" @@ -225,6 +223,7 @@ mkTopologyConfig numNodes allPorts port True = A.encodePretty topologyP2P (HotValency (numNodes - 1)) (WarmValency (numNodes - 1)) IsNotTrustable + InitiatorAndResponderDiffusionMode ] topologyP2P :: P2P.NetworkTopology @@ -234,3 +233,4 @@ mkTopologyConfig numNodes allPorts port True = A.encodePretty topologyP2P [] DontUseLedgerPeers DontUseBootstrapPeers + Nothing diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index 4977c04d37f..2697b150a81 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -465,7 +465,7 @@ getGovState -> m (L.ConwayGovState (ShelleyLedgerEra era)) -- ^ The governance state getGovState epochStateView ceo = withFrozenCallStack $ do AnyNewEpochState sbe' newEpochState <- getEpochState epochStateView - let sbe = conwayEraOnwardsToShelleyBasedEra ceo + let sbe = convert ceo Refl <- H.leftFail $ assertErasEqual sbe sbe' pure $ conwayEraOnwardsConstraints ceo $ newEpochState ^. L.newEpochStateGovStateL diff --git a/cardano-testnet/src/Testnet/Defaults.hs b/cardano-testnet/src/Testnet/Defaults.hs index fc8beba1cfd..fdfb5c06fa4 100644 --- a/cardano-testnet/src/Testnet/Defaults.hs +++ b/cardano-testnet/src/Testnet/Defaults.hs @@ -290,7 +290,7 @@ defaultYamlConfig = , ("EnableLogging", Aeson.Bool True) -- Genesis filepaths - , ("ByronGenesisFile", "byron/genesis.json") + , ("ByronGenesisFile", genesisPath ByronEra) , ("ShelleyGenesisFile", genesisPath ShelleyEra) , ("AlonzoGenesisFile", genesisPath AlonzoEra) , ("ConwayGenesisFile", genesisPath ConwayEra) @@ -545,9 +545,9 @@ plutusV3Script :: Text plutusV3Script = "{ \"type\": \"PlutusScriptV3\", \"description\": \"\", \"cborHex\": \"46450101002499\" }" --- | Created via: cabal run plutus-scripts-bench -- print SupplementalDatum -o supplemental-datum.plutus -plutusV3SupplementalDatumScript :: Text -plutusV3SupplementalDatumScript = +-- | Created via: cabal run plutus-scripts-bench -- print SupplementalDatum -o supplemental-datum.plutus +plutusV3SupplementalDatumScript :: Text +plutusV3SupplementalDatumScript = "{ \"type\": \"PlutusScriptV3\", \"description\": \"\", \"cborHex\": \"590e72590e6f01000032323322332233223232323232323232323232323225335533535353232325335333573466e1d200000201301213232323232333222123330010040030023232325335333573466e1d200000201b01a1323232323232323232323232323232323333333333332333233233222222222222222212333333333333333300101101000f00e00d00c00b00a00900800700600500400300230013574202860026ae8404cc0948c8c8c94cd4ccd5cd19b87480000080c40c04cc8848cc00400c008c074d5d080098029aba135744002260589201035054310035573c0046aae74004dd5000998128009aba101123232325335333573466e1d200000203002f13232333322221233330010050040030023232325335333573466e1d2000002035034133221233001003002302e357420026605e4646464a66a666ae68cdc3a4000004072070264244600400660646ae8400454cd4ccd5cd19b87480080080e40e04c8ccc888488ccc00401401000cdd69aba1002375a6ae84004dd69aba1357440026ae880044c0d12401035054310035573c0046aae74004dd50009aba135744002260609201035054310035573c0046aae74004dd51aba1003300735742004646464a66a666ae68cdc3a400000406a068224440062a66a666ae68cdc3a400400406a068264244460020086eb8d5d08008a99a999ab9a3370e900200101a81a099091118010021aba1001130304901035054310035573c0046aae74004dd51aba10013302c75c6ae84d5d10009aba200135744002260569201035054310035573c0046aae74004dd50009bad3574201e60026ae84038c008c009d69981180a9aba100c33302702475a6ae8402cc8c8c94cd4ccd5cd19b87480000080b80b44cc8848cc00400c008c8c8c94cd4ccd5cd19b87480000080c40c04cc8848cc00400c008cc09dd69aba10013026357426ae880044c0b1241035054310035573c0046aae74004dd51aba10013232325335333573466e1d20000020310301332212330010030023302775a6ae84004c098d5d09aba20011302c491035054310035573c0046aae74004dd51aba13574400226052921035054310035573c0046aae74004dd51aba100a3302375c6ae84024ccc09c8c8c8c94cd4ccd5cd19b87480000080bc0b84c84888888c01401cdd71aba100115335333573466e1d200200202f02e13212222223002007301b357420022a66a666ae68cdc3a400800405e05c2642444444600600e60506ae8400454cd4ccd5cd19b87480180080bc0b84cc884888888cc01802001cdd69aba10013019357426ae8800454cd4ccd5cd19b87480200080bc0b84c84888888c00401cc068d5d08008a99a999ab9a3370e9005001017817099910911111198020040039bad3574200260306ae84d5d1000898152481035054310035573c0046aae74004dd500080f9aba10083300201f3574200e6eb8d5d080319981380b198138111191919299a999ab9a3370e9000001017817089110010a99a999ab9a3370e9001001017817089110008a99a999ab9a3370e900200101781708911001898152481035054310035573c0046aae74004dd50009aba1005330230143574200860026ae8400cc004d5d09aba2003302475a604aeb8d5d10009aba2001357440026ae88004d5d10009aba2001357440026ae88004d5d10009aba2001357440026ae88004d5d10009aba200113016491035054310035573c0046aae74004dd51aba10063574200a646464a66a666ae68cdc3a40000040360342642444444600a00e6eb8d5d08008a99a999ab9a3370e900100100d80d0999109111111980100400398039aba10013301500f357426ae8800454cd4ccd5cd19b874801000806c0684c84888888c00c01cc050d5d08008a99a999ab9a3370e900300100d80d099910911111198030040039bad35742002600a6ae84d5d10008a99a999ab9a3370e900400100d80d0990911111180080398031aba100115335333573466e1d200a00201b01a13322122222233004008007375a6ae84004c010d5d09aba2001130164901035054310035573c0046aae74004dd51aba13574400a4646464a66a666ae68cdc3a4000004036034264666444246660020080060046eb4d5d0801180a9aba10013232325335333573466e1d200000201f01e1323332221222222233300300a0090083301a017357420046ae84004cc069d71aba1357440026ae8800454cd4ccd5cd19b874800800807c0784cc8848888888cc01c024020cc064058d5d0800991919299a999ab9a3370e90000010110108999109198008018011bad357420026eb4d5d09aba20011301d491035054310035573c0046aae74004dd51aba1357440022a66a666ae68cdc3a400800403e03c266442444444466004012010666036030eb4d5d08009980cbae357426ae8800454cd4ccd5cd19b874801800807c0784c848888888c010020cc064058d5d08008a99a999ab9a3370e900400100f80f09919199991110911111119998008058050048041980d80c1aba10033301901a3574200466603a034eb4d5d08009a991919299a999ab9a3370e90000010120118998149bad357420026eb4d5d09aba20011301f4901035054310035573c0046aae74004dd51aba135744002446602a0040026ae88004d5d10008a99a999ab9a3370e900500100f80f0999109111111198028048041980c80b1aba10013232325335333573466e1d200000202202113301c75c6ae840044c075241035054310035573c0046aae74004dd51aba1357440022a66a666ae68cdc3a401800403e03c22444444400c26034921035054310035573c0046aae74004dd51aba1357440026ae880044c059241035054310035573c0046aae74004dd50009191919299a999ab9a3370e900000100d00c899910911111111111980280680618099aba10013301475a6ae84d5d10008a99a999ab9a3370e900100100d00c899910911111111111980100680618099aba10013301475a6ae84d5d10008a9919a999ab9a3370e900200180d80d0999109111111111119805006806180a1aba10023001357426ae8800854cd4ccd5cd19b874801800c06c0684c8ccc888488888888888ccc018038034030c054d5d080198011aba1001375a6ae84d5d10009aba200215335333573466e1d200800301b01a133221222222222223300700d00c3014357420046eb4d5d09aba200215335333573466e1d200a00301b01a132122222222222300100c3014357420042a66a666ae68cdc3a4018006036034266442444444444446600601a01860286ae84008dd69aba1357440042a66a666ae68cdc3a401c006036034266442444444444446601201a0186eb8d5d08011bae357426ae8800854cd4ccd5cd19b874804000c06c0684cc88488888888888cc020034030dd71aba1002375a6ae84d5d10010a99a999ab9a3370e900900180d80d0999109111111111119805806806180a1aba10023014357426ae8800854cd4ccd5cd19b874805000c06c0684c8488888888888c010030c050d5d08010980b2481035054310023232325335333573466e1d200000201e01d13212223003004375c6ae8400454c8cd4ccd5cd19b874800800c07c0784c84888c004010c004d5d08010a99a999ab9a3370e900200180f80f099910911198010028021bae3574200460026ae84d5d10010980d2481035054310023232325335333573466e1d200000202202113212223003004301b357420022a66a666ae68cdc3a4004004044042224440042a66a666ae68cdc3a4008004044042224440022603a921035054310035573c0046aae74004dd50009aab9e00235573a0026ea8004d55cf0011aab9d00137540024646464a66a666ae68cdc3a40000040320302642444600600860246ae8400454cd4ccd5cd19b87480080080640604c84888c008010c048d5d08008a99a999ab9a3370e900200100c80c099091118008021bae3574200226028921035054310035573c0046aae74004dd50009191919299a999ab9a3370e900000100c00b8999109198008018011bae357420026eb4d5d09aba200113013491035054310035573c0046aae74004dd50009aba20011300e491035054310035573c0046aae74004dd50009110019111111111111111180f0031080888078a4c26016921035054350030142225335333573466e1d20000010110101300c491035054330015335333573466e20005200001101013300333702900000119b81480000044c8cc8848cc00400c008cdc200180099b840020013300400200130132225335333573466e1d200000101000f10021330030013370c00400240024646464a66a666ae68cdc3a400000401e01c201c2a66a666ae68cdc3a400400401e01c201e260149201035054310035573c0046aae74004dd500091191919299a999ab9a3370e9000001007807089110010a99a999ab9a3370e90010010078070990911180180218029aba100115335333573466e1d200400200f00e112220011300a4901035054310035573c0046aae74004dd50009191919299a999ab9a3370e90000010068060999109198008018011bae357420026eb4d5d09aba200113008491035054310035573c0046aae74004dd5000919118011bac001300f2233335573e002401c466a01a60086ae84008c00cd5d10010041191919299a999ab9a3370e900000100580509909118010019bae357420022a66a666ae68cdc3a400400401601426424460020066eb8d5d0800898032481035054310035573c0046aae74004dd500091191919299a999ab9a3370e90010010058050a8070a99a999ab9a3370e90000010058050980798029aba1001130064901035054310035573c0046aae74004dd5000919319ab9c00100322322300237560026018446666aae7c004802c8c8cd402ccc03cc018d55ce80098029aab9e0013004357440066ae8400801448004c020894cd40045401c884d4008894cd4ccd5cd19b8f488120ee155ace9c40292074cb6aff8c9ccdd273c81648ff1149ef36bcea6ebb8a3e25000020080071300c001130060031220021220011220021221223300100400321223002003112200122123300100300223230010012300223300200200101\" }" diff --git a/cardano-testnet/src/Testnet/Ping.hs b/cardano-testnet/src/Testnet/Ping.hs index 7e0242bb741..b70a08e2989 100644 --- a/cardano-testnet/src/Testnet/Ping.hs +++ b/cardano-testnet/src/Testnet/Ping.hs @@ -33,11 +33,12 @@ import Data.Either import Data.IORef import qualified Data.List as L import Data.Word (Word32) +import qualified Network.Mux as Mux import Network.Mux.Bearer (MakeBearer (..), makeSocketBearer) import Network.Mux.Timeout (TimeoutFn, withTimeoutSerial) import Network.Mux.Types (MiniProtocolDir (InitiatorDir), MiniProtocolNum (..), - MuxBearer (read, write), MuxSDU (..), MuxSDUHeader (..), - RemoteClockModel (RemoteClockModel)) + RemoteClockModel (RemoteClockModel), SDU (..), SDUHeader (..)) +import qualified Network.Mux.Types as Mux import Network.Socket (AddrInfo (..), PortNumber, StructLinger (..)) import qualified Network.Socket as Socket import Prettyprinter @@ -67,7 +68,7 @@ pingNode :: MonadIO m pingNode networkMagic sprocket = liftIO $ bracket (Socket.socket (Socket.addrFamily peer) Socket.Stream Socket.defaultProtocol) Socket.close - (\sd -> withTimeoutSerial $ \timeoutfn -> do + (\sd -> handle (pure . Left . PceException) $ withTimeoutSerial $ \timeoutfn -> do when (Socket.addrFamily peer /= Socket.AF_UNIX) $ do Socket.setSocketOption sd Socket.NoDelay 1 Socket.setSockOpt sd Socket.Linger @@ -82,7 +83,7 @@ pingNode networkMagic sprocket = liftIO $ bracket bearer <- getBearer makeSocketBearer sduTimeout nullTracer sd let versions = supportedNodeToClientVersions networkMagic - !_ <- write bearer timeoutfn $ wrap handshakeNum InitiatorDir (handshakeReq versions doHandshakeQuery) + !_ <- Mux.write bearer timeoutfn $ wrap handshakeNum InitiatorDir (handshakeReq versions doHandshakeQuery) (msg, !_) <- nextMsg bearer timeoutfn handshakeNum pure $ case CBOR.deserialiseFromBytes handshakeDec msg of @@ -96,9 +97,9 @@ pingNode networkMagic sprocket = liftIO $ bracket peer = sprocketToAddrInfo sprocket :: AddrInfo -- | Wrap a message in a mux service data unit. - wrap :: MiniProtocolNum -> MiniProtocolDir -> LBS.ByteString -> MuxSDU - wrap mhNum mhDir msBlob = MuxSDU - { msHeader = MuxSDUHeader + wrap :: MiniProtocolNum -> MiniProtocolDir -> LBS.ByteString -> SDU + wrap mhNum mhDir msBlob = SDU + { msHeader = SDUHeader { mhTimestamp = RemoteClockModel 0 , mhNum , mhDir @@ -124,12 +125,12 @@ pingNode networkMagic sprocket = liftIO $ bracket pure $ host <> ":" <> port -- | Fetch next message from mux bearer. Ignores messages not matching handshake protocol number. - nextMsg :: MuxBearer IO -- ^ a mux bearer + nextMsg :: Mux.Bearer IO -- ^ a mux bearer -> TimeoutFn IO -- ^ timeout function, for reading messages -> MiniProtocolNum -- ^ handshake protocol number -> IO (LBS.ByteString, Time) -- ^ raw message and timestamp nextMsg bearer timeoutfn ptclNum = do - (sdu, t_e) <- Network.Mux.Types.read bearer timeoutfn + (sdu, t_e) <- Mux.read bearer timeoutfn if mhNum (msHeader sdu) == ptclNum then pure (msBlob sdu, t_e) else nextMsg bearer timeoutfn ptclNum @@ -194,6 +195,8 @@ data PingClientError !String -- ^ peer string ![NodeVersion] -- ^ requested versions ![NodeVersion] -- ^ received node versions + | PceException + !SomeException instance Error PingClientError where prettyError = \case @@ -203,5 +206,6 @@ instance Error PingClientError where [ pretty peerStr <+> "Version negotiation error: No overlapping versions with" <+> viaShow requestedVersions , "Received versions:" <+> viaShow receivedVersions ] + PceException exception -> "An unknown exception occurred:" <+> pretty (displayException exception) diff --git a/cardano-testnet/src/Testnet/Process/Cli/DRep.hs b/cardano-testnet/src/Testnet/Process/Cli/DRep.hs index 23ae6e90f98..cf3a1ba7c31 100644 --- a/cardano-testnet/src/Testnet/Process/Cli/DRep.hs +++ b/cardano-testnet/src/Testnet/Process/Cli/DRep.hs @@ -227,7 +227,7 @@ registerDRep -- as returned by 'cardanoTestnetDefault'. -> m (KeyPair PaymentKey) registerDRep execConfig epochStateView ceo work prefix wallet = do - let sbe = conwayEraOnwardsToShelleyBasedEra ceo + let sbe = convert ceo era = toCardanoEra sbe cEra = AnyCardanoEra era @@ -354,7 +354,7 @@ makeActivityChangeProposal makeActivityChangeProposal execConfig epochStateView ceo work prevGovActionInfo drepActivity stakeKeyPair wallet timeout = do - let sbe = conwayEraOnwardsToShelleyBasedEra ceo + let sbe = convert ceo era = toCardanoEra sbe cEra = AnyCardanoEra era KeyPair{verificationKey=File stakeVkeyFp} = stakeKeyPair diff --git a/cardano-testnet/src/Testnet/Runtime.hs b/cardano-testnet/src/Testnet/Runtime.hs index 96055c7daad..8e3f9b414b5 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -117,7 +117,7 @@ startNode -- ^ The command to execute to start the node. -- @--socket-path@, @--port@, and @--host-addr@ gets added automatically. -> ExceptT NodeStartFailure m TestnetNode -startNode tp node ipv4 port testnetMagic nodeCmd = GHC.withFrozenCallStack $ do +startNode tp node ipv4 port _testnetMagic nodeCmd = GHC.withFrozenCallStack $ do let tempBaseAbsPath = makeTmpBaseAbsPath tp socketDir = makeSocketDir tp logDir = makeLogDir tp @@ -175,10 +175,11 @@ startNode tp node ipv4 port testnetMagic nodeCmd = GHC.withFrozenCallStack $ do -- Wait for socket to be created eSprocketError <- - Ping.waitForSprocket - 120 -- timeout - 0.2 -- check interval - sprocket + H.evalIO $ + Ping.waitForSprocket + 120 -- timeout + 0.2 -- check interval + sprocket -- If we do have anything on stderr, fail. stdErrContents <- liftIO $ IO.readFile nodeStderrFile @@ -193,8 +194,9 @@ startNode tp node ipv4 port testnetMagic nodeCmd = GHC.withFrozenCallStack $ do $ hoistEither eSprocketError -- Ping node and fail on error - Ping.pingNode (fromIntegral testnetMagic) sprocket - >>= (firstExceptT (NodeExecutableError . ("Ping error:" <+>) . prettyError) . hoistEither) + -- FIXME: pinging of the node is broken now, has the protocol changed? + -- Ping.pingNode (fromIntegral testnetMagic) sprocket + -- >>= (firstExceptT (NodeExecutableError . ("Ping error:" <+>) . prettyError) . hoistEither) pure $ TestnetNode { nodeName = node diff --git a/cardano-testnet/src/Testnet/Start/Byron.hs b/cardano-testnet/src/Testnet/Start/Byron.hs index a90116457e4..624cc0d9d6a 100644 --- a/cardano-testnet/src/Testnet/Start/Byron.hs +++ b/cardano-testnet/src/Testnet/Start/Byron.hs @@ -7,8 +7,6 @@ module Testnet.Start.Byron ( createByronGenesis - , createByronUpdateProposal - , createByronUpdateProposalVote , byronDefaultGenesisOptions ) where @@ -67,34 +65,3 @@ createByronGenesis testnetMagic' startTime testnetOptions pParamFp genOutputDir , "--genesis-output-dir", genOutputDir ] -createByronUpdateProposal - :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) - => Int -> String -> String -> Int -> m () -createByronUpdateProposal testnetMagic' signingKeyFp updateProposalFp ptclMajorVersion = - withFrozenCallStack $ execCli_ - [ "byron", "governance", "create-update-proposal" - , "--filepath", updateProposalFp - , "--testnet-magic", show testnetMagic' - , "--signing-key", signingKeyFp - , "--protocol-version-major", show ptclMajorVersion - , "--protocol-version-minor", "0" - , "--protocol-version-alt", "0" - , "--application-name", "cardano-sl" - , "--software-version-num", "1" - , "--system-tag", "linux" - , "--installer-hash", "0" - ] - -createByronUpdateProposalVote - :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) - => Int -> String -> String -> String -> m () -createByronUpdateProposalVote testnetMagic' updateProposalFp signingKey outputFp = - withFrozenCallStack $ execCli_ - [ "byron", "governance", "create-proposal-vote" - , "--proposal-filepath", updateProposalFp - , "--testnet-magic", show testnetMagic' - , "--signing-key", signingKey - , "--vote-yes" - , "--output-filepath", outputFp - ] - diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index 7609da32952..3c3f6080130 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -54,7 +54,6 @@ import qualified GHC.Stack as GHC import qualified System.Directory as IO import System.FilePath (()) import qualified System.Info as OS -import Text.Printf (printf) import Testnet.Components.Configuration import qualified Testnet.Defaults as Defaults @@ -62,7 +61,6 @@ import Testnet.Filepath import Testnet.Process.Run (execCli', execCli_, mkExecConfig) import Testnet.Property.Assert (assertChainExtended, assertExpectedSposInLedgerState) import Testnet.Runtime as TR -import qualified Testnet.Start.Byron as Byron import Testnet.Start.Types import Testnet.Types as TR hiding (shelleyGenesis) @@ -130,11 +128,7 @@ getDefaultShelleyGenesis asbe maxSupply opts = do -- | Setup a number of credentials and nodes (SPOs and relays), like this: -- --- > ├── byron --- > │   └── genesis.json -- > ├── byron-gen-command --- > │   ├── delegate-keys.00{1,2}.key --- > │   ├── delegation-cert.00{1,2}.json -- > │   └── genesis-keys.00{0,1,2}.key -- > ├── delegate-keys -- > │   ├── delegate{1,2,3} @@ -187,6 +181,7 @@ getDefaultShelleyGenesis asbe maxSupply opts = do -- > │   │   └── utxo.{addr,skey,vkey} -- > │   └── README.md -- > ├── alonzo-genesis.json +-- > ├── byron.genesis.json -- > ├── byron.genesis.spec.json -- > ├── configuration.yaml -- > ├── conway-genesis.json @@ -215,7 +210,6 @@ cardanoTestnet , cardanoNumDReps=nDReps , cardanoNodes } = testnetOptions - startTime = sgSystemStart shelleyGenesis testnetMagic = fromIntegral $ sgNetworkMagic shelleyGenesis nPools = cardanoNumPools testnetOptions AnyShelleyBasedEra sbe <- pure asbe @@ -231,16 +225,6 @@ cardanoTestnet -- See all of the ad hoc file creation/renaming/dir creation etc below. H.failMessage GHC.callStack "Specifying node configuration files per node not supported yet." - H.lbsWriteFile (tmpAbsPath "byron.genesis.spec.json") - . encode $ Defaults.defaultByronProtocolParamsJsonValue - - Byron.createByronGenesis - testnetMagic - startTime - Byron.byronDefaultGenesisOptions - (tmpAbsPath "byron.genesis.spec.json") - (tmpAbsPath "byron-gen-command") - -- Write specification files. Those are the same as the genesis files -- used for launching the nodes, but omitting the content regarding stake, utxos, etc. -- They are used by benchmarking: as templates to CLI commands, @@ -296,16 +280,10 @@ cardanoTestnet let portNumbers = snd <$> portNumbersWithNodeOptions -- Byron related - forM_ (zip [1..] portNumbersWithNodeOptions) $ \(i, (nodeOptions, portNumber)) -> do - let iStr = printf "%03d" (i - 1) - nodeDataDir = tmpAbsPath Defaults.defaultNodeDataDir i - nodePoolKeysDir = tmpAbsPath Defaults.defaultSpoKeysDir i + forM_ (zip [1..] portNumbersWithNodeOptions) $ \(i, (_nodeOptions, portNumber)) -> do + let nodeDataDir = tmpAbsPath Defaults.defaultNodeDataDir i H.evalIO $ IO.createDirectoryIfMissing True nodeDataDir H.writeFile (nodeDataDir "port") (show portNumber) - when (isSpoNodeOptions nodeOptions) $ do - H.renameFile (tmpAbsPath "byron-gen-command" "delegate-keys." <> iStr <> ".key") (nodePoolKeysDir "byron-delegate.key") - H.renameFile (tmpAbsPath "byron-gen-command" "delegation-cert." <> iStr <> ".json") (nodePoolKeysDir "byron-delegation.cert") - -- Make Non P2P topology files forM_ (zip [1..] portNumbers) $ \(i, myPortNumber) -> do diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Conway/Plutus.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Conway/Plutus.hs index 1ebede4c87d..b29a33deb71 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Conway/Plutus.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Conway/Plutus.hs @@ -55,7 +55,7 @@ hprop_plutus_v3 = integrationWorkspace "all-plutus-script-purposes" $ \tempAbsBa let tempBaseAbsPath = makeTmpBaseAbsPath $ TmpAbsolutePath tempAbsPath' ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo era = toCardanoEra sbe anyEra = AnyCardanoEra era options = def { cardanoNodeEra = AnyShelleyBasedEra sbe } diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/KesPeriodInfo.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/KesPeriodInfo.hs index dc70f16dd98..53f7b8c5345 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/KesPeriodInfo.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/KesPeriodInfo.hs @@ -62,7 +62,7 @@ hprop_kes_period_info = integrationRetryWorkspace 2 "kes-period-info" $ \tempAbs let tempBaseAbsPath = makeTmpBaseAbsPath tempAbsPath ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo asbe = AnyShelleyBasedEra sbe eraString = eraToString sbe cTestnetOptions = def { cardanoNodeEra = asbe } diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/LeadershipSchedule.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/LeadershipSchedule.hs index 40373ff4910..c2960c48519 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/LeadershipSchedule.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/LeadershipSchedule.hs @@ -62,7 +62,7 @@ hprop_leadershipSchedule = integrationRetryWorkspace 2 "leadership-schedule" $ \ conf@Conf { tempAbsPath=tempAbsPath@(TmpAbsolutePath work) } <- mkConf tempAbsBasePath' let tempBaseAbsPath = makeTmpBaseAbsPath tempAbsPath ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo asbe = AnyShelleyBasedEra sbe cTestnetOptions = def { cardanoNodeEra = asbe diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Query.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Query.hs index f190ff36fb9..3ba4db33f7b 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Query.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Query.hs @@ -81,7 +81,7 @@ import qualified Hedgehog.Extras.Test.Golden as H -- | Test CLI queries -- Execute me with: --- @cabal test cardano-testnet-test --test-options '-p "/CliQueries/"'@ +-- @DISABLE_RETRIES=1 cabal test cardano-testnet-test --test-options '-p "/CliQueries/"'@ -- If you want to recreate golden files, run the comment with -- RECREATE_GOLDEN_FILES=1 as its prefix hprop_cli_queries :: Property @@ -439,6 +439,10 @@ hprop_cli_queries = integrationWorkspace "cli-queries" $ \tempAbsBasePath' -> H. -- treasury H.noteM_ $ execCli' execConfig [ eraName, "query", "treasury" ] + TestQueryProposalsCmd -> do + -- TODO @cardano-cli team + pure () + where -- | Wait for the part of the epoch when futurePParams are known waitForFuturePParamsToStabilise diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Transaction/RegisterDeregisterStakeAddress.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Transaction/RegisterDeregisterStakeAddress.hs index 53b36186c7a..a27e01a1f89 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Transaction/RegisterDeregisterStakeAddress.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Transaction/RegisterDeregisterStakeAddress.hs @@ -49,7 +49,7 @@ hprop_tx_register_deregister_stake_address = integrationWorkspace "register-dere work <- H.createDirectoryIfMissing $ tempAbsPath' "work" let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo eraName = eraToString sbe fastTestnetOptions = def { cardanoNodeEra = AnyShelleyBasedEra sbe } shelleyOptions = def { genesisEpochLength = 200 } diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/CommitteeAddNew.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/CommitteeAddNew.hs index 997ab0753d8..cc60d11aa78 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/CommitteeAddNew.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/CommitteeAddNew.hs @@ -74,7 +74,7 @@ hprop_constitutional_committee_add_new = integrationWorkspace "constitutional-co nDrepVotes = length drepVotes nSpos = fromIntegral $ cardanoNumPools fastTestnetOptions ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo era = toCardanoEra sbe cEra = AnyCardanoEra era eraName = eraToString era @@ -160,6 +160,9 @@ hprop_constitutional_committee_add_new = integrationWorkspace "constitutional-co , "--tx-file", stakeCertTxSignedFp ] + -- make sure that stake registration cert gets into a block + _ <- waitForBlocks epochStateView 1 + minGovActDeposit <- getMinGovActionDeposit epochStateView ceo ccColdKeys <- H.noteShowM $ diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/DRepActivity.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/DRepActivity.hs index 87a3cb874ce..20eb2b5c9a5 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/DRepActivity.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/DRepActivity.hs @@ -60,7 +60,7 @@ hprop_check_drep_activity = integrationWorkspace "test-activity" $ \tempAbsBaseP -- Create default testnet with 3 DReps and 3 stake holders delegated, one to each DRep. let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo fastTestnetOptions = def { cardanoNodeEra = AnyShelleyBasedEra sbe , cardanoNumDReps = 1 @@ -219,7 +219,7 @@ activityChangeProposalTest -> m (String, Word16) -- ^ The transaction id and the index of the governance action. activityChangeProposalTest execConfig epochStateView ceo work prefix stakeKeys wallet votes change minWait mExpected maxWait = do - let sbe = conwayEraOnwardsToShelleyBasedEra ceo + let sbe = convert ceo mPreviousProposalInfo <- getLastPParamUpdateActionId execConfig diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/DRepDeposit.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/DRepDeposit.hs index 1d5fcca563c..77342d63ca4 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/DRepDeposit.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/DRepDeposit.hs @@ -42,7 +42,7 @@ hprop_ledger_events_drep_deposits = integrationWorkspace "drep-deposits" $ \temp work <- H.createDirectoryIfMissing $ tempAbsPath' "work" let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo era = toCardanoEra sbe cEra = AnyCardanoEra era fastTestnetOptions = def diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/GovActionTimeout.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/GovActionTimeout.hs index 6916c5c3fcd..69563fa1372 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/GovActionTimeout.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/GovActionTimeout.hs @@ -51,7 +51,7 @@ hprop_check_gov_action_timeout = integrationWorkspace "gov-action-timeout" $ \te -- Create default testnet let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo eraName = eraToString sbe asbe = AnyShelleyBasedEra sbe fastTestnetOptions = def { cardanoNodeEra = asbe } @@ -125,6 +125,9 @@ hprop_check_gov_action_timeout = integrationWorkspace "gov-action-timeout" $ \te , "--tx-file", stakeCertTxSignedFp ] + -- make sure that stake registration cert gets into a block + _ <- waitForBlocks epochStateView 1 + -- Create a proposal (governanceActionTxId, _governanceActionIndex) <- makeActivityChangeProposal execConfig epochStateView ceo (baseDir "proposal") diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/InfoAction.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/InfoAction.hs index ea8744af10b..dd8b3645b12 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/InfoAction.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/InfoAction.hs @@ -58,7 +58,7 @@ hprop_ledger_events_info_action = integrationRetryWorkspace 2 "info-hash" $ \tem work <- H.createDirectoryIfMissing $ tempAbsPath' "work" let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo asbe = AnyShelleyBasedEra sbe eraName = eraToString sbe fastTestnetOptions = def { cardanoNodeEra = asbe } @@ -134,6 +134,9 @@ hprop_ledger_events_info_action = integrationRetryWorkspace 2 "info-hash" $ \tem , "--tx-file", stakeCertTxSignedFp ] + -- make sure that stake registration cert gets into a block + _ <- waitForBlocks epochStateView 1 + -- Create info action proposal void $ execCli' execConfig diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs index 0912f85c1e9..c7c7623adb8 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs @@ -64,7 +64,7 @@ hprop_gov_no_confidence = integrationWorkspace "no-confidence" $ \tempAbsBasePat work <- H.createDirectoryIfMissing $ tempAbsPath' "work" let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo asbe = AnyShelleyBasedEra sbe era = toCardanoEra sbe cEra = AnyCardanoEra era diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/PParamChangeFailsSPO.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/PParamChangeFailsSPO.hs index 5218ba340c5..43c101d428e 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/PParamChangeFailsSPO.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/PParamChangeFailsSPO.hs @@ -58,7 +58,7 @@ hprop_check_pparam_fails_spo = integrationWorkspace "test-pparam-spo" $ \tempAbs -- Create default testnet let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo asbe = AnyShelleyBasedEra sbe eraName = eraToString sbe fastTestnetOptions = def { cardanoNodeEra = asbe } @@ -126,6 +126,8 @@ hprop_check_pparam_fails_spo = integrationWorkspace "test-pparam-spo" $ \tempAbs , "--tx-file", stakeCertTxSignedFp ] + -- make sure that stake registration cert gets into a block + _ <- waitForBlocks epochStateView 1 let propVotes :: [(String, Int)] propVotes = mkVotes [(1, "yes")] @@ -163,7 +165,7 @@ failToVoteChangeProposalWithSPOs ceo execConfig epochStateView work prefix governanceActionTxId governanceActionIndex votes wallet = withFrozenCallStack $ do baseDir <- H.createDirectoryIfMissing $ work prefix - let sbe = conwayEraOnwardsToShelleyBasedEra ceo + let sbe = convert ceo era = toCardanoEra sbe cEra = AnyCardanoEra era diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/PredefinedAbstainDRep.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/PredefinedAbstainDRep.hs index 6b504e94aec..7869ffaba93 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/PredefinedAbstainDRep.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/PredefinedAbstainDRep.hs @@ -74,7 +74,7 @@ hprop_check_predefined_abstain_drep = H.integrationWorkspace "test-activity" $ \ -- Create default testnet with 3 DReps and 3 stake holders delegated, one to each DRep. let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo fastTestnetOptions = def { cardanoNodeEra = AnyShelleyBasedEra sbe , cardanoNumDReps = 3 @@ -186,7 +186,7 @@ desiredPoolNumberProposalTest -> m (String, Word16) desiredPoolNumberProposalTest execConfig epochStateView ceo work prefix wallet previousProposalInfo votes change minWait mExpected maxWait = do - let sbe = conwayEraOnwardsToShelleyBasedEra ceo + let sbe = convert ceo baseDir <- H.createDirectoryIfMissing $ work prefix @@ -229,7 +229,7 @@ makeDesiredPoolNumberChangeProposal makeDesiredPoolNumberChangeProposal execConfig epochStateView ceo work prefix prevGovActionInfo desiredPoolNumber wallet = do - let sbe = conwayEraOnwardsToShelleyBasedEra ceo + let sbe = convert ceo era = toCardanoEra sbe cEra = AnyCardanoEra era diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs index b9b9eed06a2..de60bc4d1cd 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs @@ -70,7 +70,7 @@ hprop_ledger_events_propose_new_constitution = integrationWorkspace "propose-new annotateShow numVotes let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo era = toCardanoEra sbe cEra = AnyCardanoEra era eraName = eraToString sbe diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs index 9ff14059756..06793e3a943 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs @@ -52,7 +52,7 @@ hprop_ledger_events_propose_new_constitution_spo = integrationWorkspace "propose let tempBaseAbsPath = makeTmpBaseAbsPath tempAbsPath let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo era = toCardanoEra sbe cEra = AnyCardanoEra era fastTestnetOptions = def diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryDonation.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryDonation.hs index 16fbd89a13f..a0cf0a25442 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryDonation.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryDonation.hs @@ -45,7 +45,7 @@ hprop_ledger_events_treasury_donation = integrationRetryWorkspace 2 "treasury-do let tempBaseAbsPath = makeTmpBaseAbsPath tempAbsPath let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo fastTestnetOptions = def { cardanoNodeEra = AnyShelleyBasedEra sbe } shelleyOptions = def { genesisEpochLength = 100 } diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs index 0b663315af4..6415f302200 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs @@ -58,7 +58,7 @@ hprop_ledger_events_treasury_withdrawal = integrationRetryWorkspace 2 "treasury work <- H.createDirectoryIfMissing $ tempAbsPath' "work" let ceo = ConwayEraOnwardsConway - sbe = conwayEraOnwardsToShelleyBasedEra ceo + sbe = convert ceo era = toCardanoEra sbe eraName = eraToString era diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Node/Shutdown.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Node/Shutdown.hs index 773b85d24fa..e7ada7b0699 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Node/Shutdown.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Node/Shutdown.hs @@ -91,13 +91,15 @@ hprop_shutdown = integrationRetryWorkspace 2 "shutdown" $ \tempAbsBasePath' -> H H.lbsWriteFile (tempAbsPath' "byron.genesis.spec.json") . encode $ defaultByronProtocolParamsJsonValue + let byronGenesisOutputDir = tempAbsPath' "byron" + startTime <- H.noteShowIO DTC.getCurrentTime createByronGenesis testnetMagic' startTime byronDefaultGenesisOptions (tempAbsPath' "byron.genesis.spec.json") - (tempAbsPath' "byron") + byronGenesisOutputDir shelleyDir <- H.createDirectoryIfMissing $ tempAbsPath' "shelley" @@ -118,8 +120,9 @@ hprop_shutdown = integrationRetryWorkspace 2 "shutdown" $ \tempAbsBasePath' -> H , "--start-time", formatIso8601 startTime ] - byronGenesisHash <- getByronGenesisHash $ tempAbsPath' "byron/genesis.json" + byronGenesisHash <- getByronGenesisHash $ byronGenesisOutputDir "genesis.json" -- Move the files to the paths expected by 'defaultYamlHardforkViaConfig' below + H.renameFile (byronGenesisOutputDir "genesis.json") (tempAbsPath' defaultGenesisFilepath ByronEra) H.renameFile (tempAbsPath' "shelley/genesis.json") (tempAbsPath' defaultGenesisFilepath ShelleyEra) H.renameFile (tempAbsPath' "shelley/genesis.alonzo.json") (tempAbsPath' defaultGenesisFilepath AlonzoEra) H.renameFile (tempAbsPath' "shelley/genesis.conway.json") (tempAbsPath' defaultGenesisFilepath ConwayEra) diff --git a/cardano-testnet/test/cardano-testnet-test/files/golden/queries/govStateOut.json b/cardano-testnet/test/cardano-testnet-test/files/golden/queries/govStateOut.json index ff31fb08fd1..a91b4167457 100644 --- a/cardano-testnet/test/cardano-testnet-test/files/golden/queries/govStateOut.json +++ b/cardano-testnet/test/cardano-testnet-test/files/golden/queries/govStateOut.json @@ -370,237 +370,303 @@ 1 ], "PlutusV3": [ + 100788, + 420, + 1, + 1, + 1000, + 173, 0, + 1, + 1000, + 59957, + 4, + 1, + 11183, + 32, + 201305, + 8356, + 4, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 100, + 100, + 16000, + 100, + 94375, + 32, + 132994, + 32, + 61462, + 4, + 72010, + 178, 0, + 1, + 22151, + 32, + 91189, + 769, + 4, + 2, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 1000, + 42921, + 4, + 2, + 24548, + 29498, + 38, + 1, + 898148, + 27279, + 1, + 51775, + 558, + 1, + 39184, + 1000, + 60594, + 1, + 141895, + 32, + 83150, + 32, + 15299, + 32, + 76049, + 1, + 13169, + 4, + 22100, + 10, + 28999, + 74, + 1, + 28999, + 74, + 1, + 43285, + 552, + 1, + 44749, + 541, + 1, + 33852, + 32, + 68246, + 32, + 72362, + 32, + 7243, + 32, + 7391, + 32, + 11546, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 90434, + 519, 0, + 1, + 74433, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 955506, + 213312, 0, + 2, + 270652, + 22588, + 4, + 1457325, + 64566, + 4, + 20467, + 1, + 4, 0, + 141992, + 32, + 100788, + 420, + 1, + 1, + 81663, + 32, + 59498, + 32, + 20142, + 32, + 24588, + 32, + 20744, + 32, + 25933, + 32, + 24623, + 32, + 43053543, + 10, + 53384111, + 14333, + 10, + 43574283, + 26308, + 10, + 16000, + 100, + 16000, + 100, + 962335, + 18, + 2780678, + 6, + 442008, + 1, + 52538055, + 3756, + 18, + 267929, + 18, + 76433006, + 8868, + 18, + 52948122, + 18, + 1995836, + 36, + 3227919, + 12, + 901022, + 1, + 166917843, + 4307, + 36, + 284546, + 36, + 158221314, + 26549, + 36, + 74698472, + 36, + 333849714, + 1, + 254006273, + 72, + 2174038, + 72, + 2261318, + 64571, + 4, + 207616, + 8310, + 4, + 1293828, + 28716, + 63, 0, + 1, + 1006041, + 43623, + 251, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 107878, + 680, 0, + 1, + 95336, + 1, + 281145, + 18848, 0, + 1, + 180194, + 159, + 1, + 1, + 158519, + 8942, 0, + 1, + 159378, + 8813, 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0 + 1, + 107490, + 3298, + 1, + 106057, + 655, + 1, + 1964219, + 24520, + 3 ] }, "dRepActivity": 100, @@ -654,203 +720,35 @@ }, "stakeAddressDeposit": 400000, "stakePoolDeposit": 0, - "stakePoolTargetNum": 100, - "treasuryCut": 0.1, - "txFeeFixed": 0, - "txFeePerByte": 1, - "utxoCostPerByte": 4310 - }, - "futurePParams": { - "tag": "NoPParamsUpdate" - }, - "nextRatifyState": { - "enactedGovActions": [], - "expiredGovActions": [], - "nextEnactState": { - "committee": { - "members": {}, - "threshold": 0 - }, - "constitution": { - "anchor": { - "dataHash": "0000000000000000000000000000000000000000000000000000000000000000", - "url": "" - } - }, - "curPParams": { - "collateralPercentage": 150, - "committeeMaxTermLength": 200, - "committeeMinSize": 0, - "costModels": { - "PlutusV1": [ - 205665, - 812, - 1, - 1, - 1000, - 571, - 0, - 1, - 1000, - 24177, - 4, - 1, - 1000, - 32, - 117366, - 10475, - 4, - 23000, - 100, - 23000, - 100, - 23000, - 100, - 23000, - 100, - 23000, - 100, - 23000, - 100, - 100, - 100, - 23000, - 100, - 19537, - 32, - 175354, - 32, - 46417, - 4, - 221973, - 511, - 0, - 1, - 89141, - 32, - 497525, - 14068, - 4, - 2, - 196500, - 453240, - 220, - 0, - 1, - 1, - 1000, - 28662, - 4, - 2, - 245000, - 216773, - 62, - 1, - 1060367, - 12586, - 1, - 208512, - 421, - 1, - 187000, - 1000, - 52998, - 1, - 80436, - 32, - 43249, - 32, - 1000, - 32, - 80556, - 1, - 57667, - 4, - 1000, - 10, - 197145, - 156, - 1, - 197145, - 156, - 1, - 204924, - 473, - 1, - 208896, - 511, - 1, - 52467, - 32, - 64832, - 32, - 65493, - 32, - 22558, - 32, - 16563, - 32, - 76511, - 32, - 196500, - 453240, - 220, - 0, - 1, - 1, - 69522, - 11687, - 0, - 1, - 60091, - 32, - 196500, - 453240, - 220, - 0, - 1, - 1, - 196500, - 453240, - 220, - 0, - 1, - 1, - 806990, - 30482, - 4, - 1927926, - 82523, - 4, - 265318, - 0, - 4, - 0, - 85931, - 32, - 205665, - 812, - 1, - 1, - 41182, - 32, - 212342, - 32, - 31220, - 32, - 32696, - 32, - 43357, - 32, - 32247, - 32, - 38314, - 32, - 57996947, - 18975, - 10 - ], - "PlutusV2": [ + "stakePoolTargetNum": 100, + "treasuryCut": 0.1, + "txFeeFixed": 0, + "txFeePerByte": 1, + "utxoCostPerByte": 4310 + }, + "futurePParams": { + "tag": "NoPParamsUpdate" + }, + "nextRatifyState": { + "enactedGovActions": [], + "expiredGovActions": [], + "nextEnactState": { + "committee": { + "members": {}, + "threshold": 0 + }, + "constitution": { + "anchor": { + "dataHash": "0000000000000000000000000000000000000000000000000000000000000000", + "url": "" + } + }, + "curPParams": { + "collateralPercentage": 150, + "committeeMaxTermLength": 200, + "committeeMinSize": 0, + "costModels": { + "PlutusV1": [ 205665, 812, 1, @@ -984,10 +882,6 @@ 0, 1, 1, - 1159724, - 392670, - 0, - 2, 806990, 30482, 4, @@ -1015,260 +909,498 @@ 43357, 32, 32247, - 32, - 38314, - 32, - 35892428, - 10, - 9462713, - 1021, - 10, - 38887044, - 32947, - 10, - 1292075, - 24469, - 74, - 0, - 1, - 936157, - 49601, - 237, - 0, - 1 - ], - "PlutusV3": [ - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, + 32, + 38314, + 32, + 57996947, + 18975, + 10 + ], + "PlutusV2": [ + 205665, + 812, + 1, + 1, + 1000, + 571, 0, + 1, + 1000, + 24177, + 4, + 1, + 1000, + 32, + 117366, + 10475, + 4, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 100, + 100, + 23000, + 100, + 19537, + 32, + 175354, + 32, + 46417, + 4, + 221973, + 511, 0, + 1, + 89141, + 32, + 497525, + 14068, + 4, + 2, + 196500, + 453240, + 220, 0, + 1, + 1, + 1000, + 28662, + 4, + 2, + 245000, + 216773, + 62, + 1, + 1060367, + 12586, + 1, + 208512, + 421, + 1, + 187000, + 1000, + 52998, + 1, + 80436, + 32, + 43249, + 32, + 1000, + 32, + 80556, + 1, + 57667, + 4, + 1000, + 10, + 197145, + 156, + 1, + 197145, + 156, + 1, + 204924, + 473, + 1, + 208896, + 511, + 1, + 52467, + 32, + 64832, + 32, + 65493, + 32, + 22558, + 32, + 16563, + 32, + 76511, + 32, + 196500, + 453240, + 220, 0, + 1, + 1, + 69522, + 11687, 0, + 1, + 60091, + 32, + 196500, + 453240, + 220, 0, + 1, + 1, + 196500, + 453240, + 220, 0, + 1, + 1, + 1159724, + 392670, 0, + 2, + 806990, + 30482, + 4, + 1927926, + 82523, + 4, + 265318, 0, + 4, 0, + 85931, + 32, + 205665, + 812, + 1, + 1, + 41182, + 32, + 212342, + 32, + 31220, + 32, + 32696, + 32, + 43357, + 32, + 32247, + 32, + 38314, + 32, + 35892428, + 10, + 9462713, + 1021, + 10, + 38887044, + 32947, + 10, + 1292075, + 24469, + 74, 0, + 1, + 936157, + 49601, + 237, 0, + 1 + ], + "PlutusV3": [ + 100788, + 420, + 1, + 1, + 1000, + 173, 0, + 1, + 1000, + 59957, + 4, + 1, + 11183, + 32, + 201305, + 8356, + 4, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 100, + 100, + 16000, + 100, + 94375, + 32, + 132994, + 32, + 61462, + 4, + 72010, + 178, 0, + 1, + 22151, + 32, + 91189, + 769, + 4, + 2, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 1000, + 42921, + 4, + 2, + 24548, + 29498, + 38, + 1, + 898148, + 27279, + 1, + 51775, + 558, + 1, + 39184, + 1000, + 60594, + 1, + 141895, + 32, + 83150, + 32, + 15299, + 32, + 76049, + 1, + 13169, + 4, + 22100, + 10, + 28999, + 74, + 1, + 28999, + 74, + 1, + 43285, + 552, + 1, + 44749, + 541, + 1, + 33852, + 32, + 68246, + 32, + 72362, + 32, + 7243, + 32, + 7391, + 32, + 11546, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 90434, + 519, 0, + 1, + 74433, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 955506, + 213312, 0, + 2, + 270652, + 22588, + 4, + 1457325, + 64566, + 4, + 20467, + 1, + 4, 0, + 141992, + 32, + 100788, + 420, + 1, + 1, + 81663, + 32, + 59498, + 32, + 20142, + 32, + 24588, + 32, + 20744, + 32, + 25933, + 32, + 24623, + 32, + 43053543, + 10, + 53384111, + 14333, + 10, + 43574283, + 26308, + 10, + 16000, + 100, + 16000, + 100, + 962335, + 18, + 2780678, + 6, + 442008, + 1, + 52538055, + 3756, + 18, + 267929, + 18, + 76433006, + 8868, + 18, + 52948122, + 18, + 1995836, + 36, + 3227919, + 12, + 901022, + 1, + 166917843, + 4307, + 36, + 284546, + 36, + 158221314, + 26549, + 36, + 74698472, + 36, + 333849714, + 1, + 254006273, + 72, + 2174038, + 72, + 2261318, + 64571, + 4, + 207616, + 8310, + 4, + 1293828, + 28716, + 63, 0, + 1, + 1006041, + 43623, + 251, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 107878, + 680, 0, + 1, + 95336, + 1, + 281145, + 18848, 0, + 1, + 180194, + 159, + 1, + 1, + 158519, + 8942, 0, + 1, + 159378, + 8813, 0, - 0 + 1, + 107490, + 3298, + 1, + 106057, + 655, + 1, + 1964219, + 24520, + 3 ] }, "dRepActivity": 100, @@ -1695,237 +1827,303 @@ 1 ], "PlutusV3": [ + 100788, + 420, + 1, + 1, + 1000, + 173, 0, + 1, + 1000, + 59957, + 4, + 1, + 11183, + 32, + 201305, + 8356, + 4, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 100, + 100, + 16000, + 100, + 94375, + 32, + 132994, + 32, + 61462, + 4, + 72010, + 178, 0, + 1, + 22151, + 32, + 91189, + 769, + 4, + 2, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 1000, + 42921, + 4, + 2, + 24548, + 29498, + 38, + 1, + 898148, + 27279, + 1, + 51775, + 558, + 1, + 39184, + 1000, + 60594, + 1, + 141895, + 32, + 83150, + 32, + 15299, + 32, + 76049, + 1, + 13169, + 4, + 22100, + 10, + 28999, + 74, + 1, + 28999, + 74, + 1, + 43285, + 552, + 1, + 44749, + 541, + 1, + 33852, + 32, + 68246, + 32, + 72362, + 32, + 7243, + 32, + 7391, + 32, + 11546, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 90434, + 519, 0, + 1, + 74433, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 955506, + 213312, 0, + 2, + 270652, + 22588, + 4, + 1457325, + 64566, + 4, + 20467, + 1, + 4, 0, + 141992, + 32, + 100788, + 420, + 1, + 1, + 81663, + 32, + 59498, + 32, + 20142, + 32, + 24588, + 32, + 20744, + 32, + 25933, + 32, + 24623, + 32, + 43053543, + 10, + 53384111, + 14333, + 10, + 43574283, + 26308, + 10, + 16000, + 100, + 16000, + 100, + 962335, + 18, + 2780678, + 6, + 442008, + 1, + 52538055, + 3756, + 18, + 267929, + 18, + 76433006, + 8868, + 18, + 52948122, + 18, + 1995836, + 36, + 3227919, + 12, + 901022, + 1, + 166917843, + 4307, + 36, + 284546, + 36, + 158221314, + 26549, + 36, + 74698472, + 36, + 333849714, + 1, + 254006273, + 72, + 2174038, + 72, + 2261318, + 64571, + 4, + 207616, + 8310, + 4, + 1293828, + 28716, + 63, 0, + 1, + 1006041, + 43623, + 251, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 107878, + 680, 0, + 1, + 95336, + 1, + 281145, + 18848, 0, + 1, + 180194, + 159, + 1, + 1, + 158519, + 8942, 0, + 1, + 159378, + 8813, 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0 + 1, + 107490, + 3298, + 1, + 106057, + 655, + 1, + 1964219, + 24520, + 3 ] }, "dRepActivity": 100, @@ -1979,189 +2177,21 @@ }, "stakeAddressDeposit": 400000, "stakePoolDeposit": 0, - "stakePoolTargetNum": 100, - "treasuryCut": 0.1, - "txFeeFixed": 0, - "txFeePerByte": 1, - "utxoCostPerByte": 4310 - } - }, - "ratificationDelayed": false - }, - "previousPParams": { - "collateralPercentage": 150, - "committeeMaxTermLength": 200, - "committeeMinSize": 0, - "costModels": { - "PlutusV1": [ - 205665, - 812, - 1, - 1, - 1000, - 571, - 0, - 1, - 1000, - 24177, - 4, - 1, - 1000, - 32, - 117366, - 10475, - 4, - 23000, - 100, - 23000, - 100, - 23000, - 100, - 23000, - 100, - 23000, - 100, - 23000, - 100, - 100, - 100, - 23000, - 100, - 19537, - 32, - 175354, - 32, - 46417, - 4, - 221973, - 511, - 0, - 1, - 89141, - 32, - 497525, - 14068, - 4, - 2, - 196500, - 453240, - 220, - 0, - 1, - 1, - 1000, - 28662, - 4, - 2, - 245000, - 216773, - 62, - 1, - 1060367, - 12586, - 1, - 208512, - 421, - 1, - 187000, - 1000, - 52998, - 1, - 80436, - 32, - 43249, - 32, - 1000, - 32, - 80556, - 1, - 57667, - 4, - 1000, - 10, - 197145, - 156, - 1, - 197145, - 156, - 1, - 204924, - 473, - 1, - 208896, - 511, - 1, - 52467, - 32, - 64832, - 32, - 65493, - 32, - 22558, - 32, - 16563, - 32, - 76511, - 32, - 196500, - 453240, - 220, - 0, - 1, - 1, - 69522, - 11687, - 0, - 1, - 60091, - 32, - 196500, - 453240, - 220, - 0, - 1, - 1, - 196500, - 453240, - 220, - 0, - 1, - 1, - 806990, - 30482, - 4, - 1927926, - 82523, - 4, - 265318, - 0, - 4, - 0, - 85931, - 32, - 205665, - 812, - 1, - 1, - 41182, - 32, - 212342, - 32, - 31220, - 32, - 32696, - 32, - 43357, - 32, - 32247, - 32, - 38314, - 32, - 57996947, - 18975, - 10 - ], - "PlutusV2": [ + "stakePoolTargetNum": 100, + "treasuryCut": 0.1, + "txFeeFixed": 0, + "txFeePerByte": 1, + "utxoCostPerByte": 4310 + } + }, + "ratificationDelayed": false + }, + "previousPParams": { + "collateralPercentage": 150, + "committeeMaxTermLength": 200, + "committeeMinSize": 0, + "costModels": { + "PlutusV1": [ 205665, 812, 1, @@ -2295,10 +2325,6 @@ 0, 1, 1, - 1159724, - 392670, - 0, - 2, 806990, 30482, 4, @@ -2329,257 +2355,495 @@ 32, 38314, 32, - 35892428, - 10, - 9462713, - 1021, - 10, - 38887044, - 32947, - 10, - 1292075, - 24469, - 74, - 0, - 1, - 936157, - 49601, - 237, - 0, - 1 + 57996947, + 18975, + 10 ], - "PlutusV3": [ - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, + "PlutusV2": [ + 205665, + 812, + 1, + 1, + 1000, + 571, 0, + 1, + 1000, + 24177, + 4, + 1, + 1000, + 32, + 117366, + 10475, + 4, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 23000, + 100, + 100, + 100, + 23000, + 100, + 19537, + 32, + 175354, + 32, + 46417, + 4, + 221973, + 511, 0, + 1, + 89141, + 32, + 497525, + 14068, + 4, + 2, + 196500, + 453240, + 220, 0, + 1, + 1, + 1000, + 28662, + 4, + 2, + 245000, + 216773, + 62, + 1, + 1060367, + 12586, + 1, + 208512, + 421, + 1, + 187000, + 1000, + 52998, + 1, + 80436, + 32, + 43249, + 32, + 1000, + 32, + 80556, + 1, + 57667, + 4, + 1000, + 10, + 197145, + 156, + 1, + 197145, + 156, + 1, + 204924, + 473, + 1, + 208896, + 511, + 1, + 52467, + 32, + 64832, + 32, + 65493, + 32, + 22558, + 32, + 16563, + 32, + 76511, + 32, + 196500, + 453240, + 220, 0, + 1, + 1, + 69522, + 11687, 0, + 1, + 60091, + 32, + 196500, + 453240, + 220, 0, + 1, + 1, + 196500, + 453240, + 220, 0, + 1, + 1, + 1159724, + 392670, 0, + 2, + 806990, + 30482, + 4, + 1927926, + 82523, + 4, + 265318, 0, + 4, 0, + 85931, + 32, + 205665, + 812, + 1, + 1, + 41182, + 32, + 212342, + 32, + 31220, + 32, + 32696, + 32, + 43357, + 32, + 32247, + 32, + 38314, + 32, + 35892428, + 10, + 9462713, + 1021, + 10, + 38887044, + 32947, + 10, + 1292075, + 24469, + 74, 0, + 1, + 936157, + 49601, + 237, 0, + 1 + ], + "PlutusV3": [ + 100788, + 420, + 1, + 1, + 1000, + 173, 0, + 1, + 1000, + 59957, + 4, + 1, + 11183, + 32, + 201305, + 8356, + 4, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 100, + 100, + 16000, + 100, + 94375, + 32, + 132994, + 32, + 61462, + 4, + 72010, + 178, 0, + 1, + 22151, + 32, + 91189, + 769, + 4, + 2, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 1000, + 42921, + 4, + 2, + 24548, + 29498, + 38, + 1, + 898148, + 27279, + 1, + 51775, + 558, + 1, + 39184, + 1000, + 60594, + 1, + 141895, + 32, + 83150, + 32, + 15299, + 32, + 76049, + 1, + 13169, + 4, + 22100, + 10, + 28999, + 74, + 1, + 28999, + 74, + 1, + 43285, + 552, + 1, + 44749, + 541, + 1, + 33852, + 32, + 68246, + 32, + 72362, + 32, + 7243, + 32, + 7391, + 32, + 11546, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 90434, + 519, 0, + 1, + 74433, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 955506, + 213312, 0, + 2, + 270652, + 22588, + 4, + 1457325, + 64566, + 4, + 20467, + 1, + 4, 0, + 141992, + 32, + 100788, + 420, + 1, + 1, + 81663, + 32, + 59498, + 32, + 20142, + 32, + 24588, + 32, + 20744, + 32, + 25933, + 32, + 24623, + 32, + 43053543, + 10, + 53384111, + 14333, + 10, + 43574283, + 26308, + 10, + 16000, + 100, + 16000, + 100, + 962335, + 18, + 2780678, + 6, + 442008, + 1, + 52538055, + 3756, + 18, + 267929, + 18, + 76433006, + 8868, + 18, + 52948122, + 18, + 1995836, + 36, + 3227919, + 12, + 901022, + 1, + 166917843, + 4307, + 36, + 284546, + 36, + 158221314, + 26549, + 36, + 74698472, + 36, + 333849714, + 1, + 254006273, + 72, + 2174038, + 72, + 2261318, + 64571, + 4, + 207616, + 8310, + 4, + 1293828, + 28716, + 63, 0, + 1, + 1006041, + 43623, + 251, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 107878, + 680, 0, + 1, + 95336, + 1, + 281145, + 18848, 0, + 1, + 180194, + 159, + 1, + 1, + 158519, + 8942, 0, + 1, + 159378, + 8813, 0, - 0 + 1, + 107490, + 3298, + 1, + 106057, + 655, + 1, + 1964219, + 24520, + 3 ] }, "dRepActivity": 100, diff --git a/cardano-testnet/test/cardano-testnet-test/files/golden/queries/protocolParametersFileOut.json b/cardano-testnet/test/cardano-testnet-test/files/golden/queries/protocolParametersFileOut.json index b66a0bee7ee..f5a86e40d9f 100644 --- a/cardano-testnet/test/cardano-testnet-test/files/golden/queries/protocolParametersFileOut.json +++ b/cardano-testnet/test/cardano-testnet-test/files/golden/queries/protocolParametersFileOut.json @@ -359,237 +359,303 @@ 1 ], "PlutusV3": [ + 100788, + 420, + 1, + 1, + 1000, + 173, 0, + 1, + 1000, + 59957, + 4, + 1, + 11183, + 32, + 201305, + 8356, + 4, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 100, + 100, + 16000, + 100, + 94375, + 32, + 132994, + 32, + 61462, + 4, + 72010, + 178, 0, + 1, + 22151, + 32, + 91189, + 769, + 4, + 2, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 1000, + 42921, + 4, + 2, + 24548, + 29498, + 38, + 1, + 898148, + 27279, + 1, + 51775, + 558, + 1, + 39184, + 1000, + 60594, + 1, + 141895, + 32, + 83150, + 32, + 15299, + 32, + 76049, + 1, + 13169, + 4, + 22100, + 10, + 28999, + 74, + 1, + 28999, + 74, + 1, + 43285, + 552, + 1, + 44749, + 541, + 1, + 33852, + 32, + 68246, + 32, + 72362, + 32, + 7243, + 32, + 7391, + 32, + 11546, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 90434, + 519, 0, + 1, + 74433, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 955506, + 213312, 0, + 2, + 270652, + 22588, + 4, + 1457325, + 64566, + 4, + 20467, + 1, + 4, 0, + 141992, + 32, + 100788, + 420, + 1, + 1, + 81663, + 32, + 59498, + 32, + 20142, + 32, + 24588, + 32, + 20744, + 32, + 25933, + 32, + 24623, + 32, + 43053543, + 10, + 53384111, + 14333, + 10, + 43574283, + 26308, + 10, + 16000, + 100, + 16000, + 100, + 962335, + 18, + 2780678, + 6, + 442008, + 1, + 52538055, + 3756, + 18, + 267929, + 18, + 76433006, + 8868, + 18, + 52948122, + 18, + 1995836, + 36, + 3227919, + 12, + 901022, + 1, + 166917843, + 4307, + 36, + 284546, + 36, + 158221314, + 26549, + 36, + 74698472, + 36, + 333849714, + 1, + 254006273, + 72, + 2174038, + 72, + 2261318, + 64571, + 4, + 207616, + 8310, + 4, + 1293828, + 28716, + 63, 0, + 1, + 1006041, + 43623, + 251, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 107878, + 680, 0, + 1, + 95336, + 1, + 281145, + 18848, 0, + 1, + 180194, + 159, + 1, + 1, + 158519, + 8942, 0, + 1, + 159378, + 8813, 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0 + 1, + 107490, + 3298, + 1, + 106057, + 655, + 1, + 1964219, + 24520, + 3 ] }, "dRepActivity": 100, diff --git a/cardano-testnet/test/cardano-testnet-test/files/golden/queries/protocolParametersOut.txt b/cardano-testnet/test/cardano-testnet-test/files/golden/queries/protocolParametersOut.txt index b66a0bee7ee..f5a86e40d9f 100644 --- a/cardano-testnet/test/cardano-testnet-test/files/golden/queries/protocolParametersOut.txt +++ b/cardano-testnet/test/cardano-testnet-test/files/golden/queries/protocolParametersOut.txt @@ -359,237 +359,303 @@ 1 ], "PlutusV3": [ + 100788, + 420, + 1, + 1, + 1000, + 173, 0, + 1, + 1000, + 59957, + 4, + 1, + 11183, + 32, + 201305, + 8356, + 4, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 100, + 100, + 16000, + 100, + 94375, + 32, + 132994, + 32, + 61462, + 4, + 72010, + 178, 0, + 1, + 22151, + 32, + 91189, + 769, + 4, + 2, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 1000, + 42921, + 4, + 2, + 24548, + 29498, + 38, + 1, + 898148, + 27279, + 1, + 51775, + 558, + 1, + 39184, + 1000, + 60594, + 1, + 141895, + 32, + 83150, + 32, + 15299, + 32, + 76049, + 1, + 13169, + 4, + 22100, + 10, + 28999, + 74, + 1, + 28999, + 74, + 1, + 43285, + 552, + 1, + 44749, + 541, + 1, + 33852, + 32, + 68246, + 32, + 72362, + 32, + 7243, + 32, + 7391, + 32, + 11546, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 90434, + 519, 0, + 1, + 74433, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 1, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, 0, + 1, + 955506, + 213312, 0, + 2, + 270652, + 22588, + 4, + 1457325, + 64566, + 4, + 20467, + 1, + 4, 0, + 141992, + 32, + 100788, + 420, + 1, + 1, + 81663, + 32, + 59498, + 32, + 20142, + 32, + 24588, + 32, + 20744, + 32, + 25933, + 32, + 24623, + 32, + 43053543, + 10, + 53384111, + 14333, + 10, + 43574283, + 26308, + 10, + 16000, + 100, + 16000, + 100, + 962335, + 18, + 2780678, + 6, + 442008, + 1, + 52538055, + 3756, + 18, + 267929, + 18, + 76433006, + 8868, + 18, + 52948122, + 18, + 1995836, + 36, + 3227919, + 12, + 901022, + 1, + 166917843, + 4307, + 36, + 284546, + 36, + 158221314, + 26549, + 36, + 74698472, + 36, + 333849714, + 1, + 254006273, + 72, + 2174038, + 72, + 2261318, + 64571, + 4, + 207616, + 8310, + 4, + 1293828, + 28716, + 63, 0, + 1, + 1006041, + 43623, + 251, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 100181, + 726, + 719, 0, + 1, + 107878, + 680, 0, + 1, + 95336, + 1, + 281145, + 18848, 0, + 1, + 180194, + 159, + 1, + 1, + 158519, + 8942, 0, + 1, + 159378, + 8813, 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0 + 1, + 107490, + 3298, + 1, + 106057, + 655, + 1, + 1964219, + 24520, + 3 ] }, "dRepActivity": 100, diff --git a/cardano-testnet/test/cardano-testnet-test/files/golden/tx.failed.response.json.golden b/cardano-testnet/test/cardano-testnet-test/files/golden/tx.failed.response.json.golden index fa3deeabecf..fa4b52b60a8 100644 --- a/cardano-testnet/test/cardano-testnet-test/files/golden/tx.failed.response.json.golden +++ b/cardano-testnet/test/cardano-testnet-test/files/golden/tx.failed.response.json.golden @@ -4,7 +4,7 @@ "contents": { "era": "ShelleyBasedEraConway", "error": [ - "ConwayUtxowFailure (UtxoFailure (ValueNotConservedUTxO (MaryValue (Coin 0) (MultiAsset (fromList []))) (MaryValue (Coin 15000003000000) (MultiAsset (fromList [])))))", + "ConwayUtxowFailure (UtxoFailure (ValueNotConservedUTxO (Mismatch {mismatchSupplied = MaryValue (Coin 0) (MultiAsset (fromList [])), mismatchExpected = MaryValue (Coin 15000003000000) (MultiAsset (fromList []))})))", "ConwayUtxowFailure (UtxoFailure (BadInputsUTxO (fromList [TxIn (TxId {unTxId = SafeHash \"xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\"}) (TxIx {unTxIx = 0})])))" ], "kind": "ShelleyTxValidationError" diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 7f6efc072d3..c505b64dbe0 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -176,8 +176,9 @@ library , filepath , http-types , mime-mail + , network-mux , optparse-applicative - , ouroboros-network ^>= 0.17 + , ouroboros-network ^>= 0.18 , ouroboros-network-api , ouroboros-network-framework , signal @@ -246,6 +247,7 @@ library demo-forwarder-lib , extra , filepath , generic-data + , network-mux , optparse-applicative-fork , ouroboros-network-api , ouroboros-network-framework @@ -347,6 +349,7 @@ test-suite cardano-tracer-test , extra , filepath , generic-data + , network-mux , optparse-applicative-fork , ouroboros-network-api , ouroboros-network-framework @@ -405,6 +408,7 @@ test-suite cardano-tracer-test-ext , filepath , generic-data , Glob + , network-mux , optparse-applicative-fork , ouroboros-network , ouroboros-network-api diff --git a/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs b/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs index deff7407fd1..505f5373b55 100644 --- a/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs +++ b/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs @@ -19,12 +19,13 @@ import Cardano.Tracer.Environment import Cardano.Tracer.Handlers.Logs.TraceObjects (deregisterNodeId, traceObjectsHandler) import Cardano.Tracer.MetaTrace import Cardano.Tracer.Utils (connIdToNodeId) +import qualified Network.Mux as Mux import Ouroboros.Network.Context (MinimalInitiatorContext (..), ResponderContext (..)) import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits) import Ouroboros.Network.IOManager (withIOManager) import Ouroboros.Network.Magic (NetworkMagic (..)) import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (..), - MiniProtocolNum (..), MuxMode (..), OuroborosApplication (..), + MiniProtocolNum (..), OuroborosApplication (..), RunMiniProtocol (..), miniProtocolLimits, miniProtocolNum, miniProtocolRun) import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, codecHandshake, noTimeLimitsHandshake) @@ -33,12 +34,13 @@ import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion simpleSingletonVersions) import Ouroboros.Network.Snocket (LocalAddress, LocalSocket, Snocket, localAddressFromPath, localSnocket, makeLocalBearer) -import Ouroboros.Network.Socket (ConnectionId (..), HandshakeCallbacks (..), - connectToNode, nullNetworkConnectTracers) +import Ouroboros.Network.Socket (ConnectionId (..), ConnectToArgs (..), + HandshakeCallbacks (..), connectToNode, nullNetworkConnectTracers) import Codec.CBOR.Term (Term) +import Control.Exception (throwIO) import qualified Data.ByteString.Lazy as LBS -import Data.Void (Void) +import Data.Void (Void, absurd) import Data.Word (Word32) import qualified System.Metrics.Configuration as EKGF import System.Metrics.Network.Acceptor (acceptEKGMetricsInit) @@ -93,21 +95,17 @@ doConnectToForwarder -> LocalAddress -> Word32 -> ProtocolTimeLimits (Handshake ForwardingVersion Term) - -> OuroborosApplication 'InitiatorMode + -> OuroborosApplication 'Mux.InitiatorMode (MinimalInitiatorContext LocalAddress) (ResponderContext LocalAddress) LBS.ByteString IO () Void -> IO () -doConnectToForwarder snocket address netMagic timeLimits app = - connectToNode +doConnectToForwarder snocket address netMagic timeLimits app = do + done <- connectToNode snocket makeLocalBearer + args mempty -- LocalSocket does not require to be configured - (codecHandshake forwardingVersionCodec) - timeLimits - (cborTermVersionDataCodec forwardingCodecCBORTerm) - nullNetworkConnectTracers - (HandshakeCallbacks acceptableVersion queryVersion) (simpleSingletonVersions ForwardingV_1 (ForwardingVersionData $ NetworkMagic netMagic) @@ -115,12 +113,24 @@ doConnectToForwarder snocket address netMagic timeLimits app = ) Nothing address + case done of + Left err -> throwIO err + Right choice -> case choice of + Left () -> return () + Right void -> absurd void + where + args = ConnectToArgs { + ctaHandshakeCodec = codecHandshake forwardingVersionCodec, + ctaHandshakeTimeLimits = timeLimits, + ctaVersionDataCodec = cborTermVersionDataCodec forwardingCodecCBORTerm, + ctaConnectTracers = nullNetworkConnectTracers, + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } runEKGAcceptorInit :: TracerEnv -> EKGF.AcceptorConfiguration -> (ConnectionId LocalAddress -> IO ()) - -> RunMiniProtocol 'InitiatorMode + -> RunMiniProtocol 'Mux.InitiatorMode (MinimalInitiatorContext LocalAddress) respoinderCtx LBS.ByteString IO () Void @@ -135,7 +145,7 @@ runTraceObjectsAcceptorInit -> TracerEnvRTView -> TF.AcceptorConfiguration TraceObject -> (ConnectionId LocalAddress -> IO ()) - -> RunMiniProtocol 'InitiatorMode + -> RunMiniProtocol 'Mux.InitiatorMode (MinimalInitiatorContext LocalAddress) responderCtx LBS.ByteString IO () Void @@ -149,7 +159,7 @@ runDataPointsAcceptorInit :: TracerEnv -> DPF.AcceptorConfiguration -> (ConnectionId LocalAddress -> IO ()) - -> RunMiniProtocol 'InitiatorMode + -> RunMiniProtocol 'Mux.InitiatorMode (MinimalInitiatorContext LocalAddress) responderCtx LBS.ByteString IO () Void diff --git a/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs b/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs index efd81ab65c2..b44f4f46b7c 100644 --- a/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs +++ b/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs @@ -21,13 +21,14 @@ import Cardano.Tracer.Environment import Cardano.Tracer.Handlers.Logs.TraceObjects (deregisterNodeId, traceObjectsHandler) import Cardano.Tracer.MetaTrace import Cardano.Tracer.Utils (connIdToNodeId) +import qualified Network.Mux as Mux import Ouroboros.Network.Context (MinimalInitiatorContext (..), ResponderContext (..)) import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits) import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) import Ouroboros.Network.IOManager (withIOManager) import Ouroboros.Network.Magic (NetworkMagic (..)) import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (..), - MiniProtocolNum (..), MuxMode (..), OuroborosApplication (..), + MiniProtocolNum (..), OuroborosApplication (..), RunMiniProtocol (..), miniProtocolLimits, miniProtocolNum, miniProtocolRun) import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, codecHandshake, noTimeLimitsHandshake) @@ -99,7 +100,7 @@ doListenToForwarder -> LocalAddress -> Word32 -> ProtocolTimeLimits (Handshake ForwardingVersion Term) - -> OuroborosApplication 'ResponderMode + -> OuroborosApplication 'Mux.ResponderMode (MinimalInitiatorContext LocalAddress) (ResponderContext LocalAddress) LBS.ByteString IO Void () @@ -131,7 +132,7 @@ runEKGAcceptor :: TracerEnv -> EKGF.AcceptorConfiguration -> (ConnectionId LocalAddress -> IO ()) - -> RunMiniProtocol 'ResponderMode initiatorCtx (ResponderContext LocalAddress) LBS.ByteString IO Void () + -> RunMiniProtocol 'Mux.ResponderMode initiatorCtx (ResponderContext LocalAddress) LBS.ByteString IO Void () runEKGAcceptor tracerEnv ekgConfig errorHandler = acceptEKGMetricsResp ekgConfig @@ -143,7 +144,7 @@ runTraceObjectsAcceptor -> TracerEnvRTView -> TF.AcceptorConfiguration TraceObject -> (ConnectionId LocalAddress -> IO ()) - -> RunMiniProtocol 'ResponderMode + -> RunMiniProtocol 'Mux.ResponderMode initiatorCtx (ResponderContext LocalAddress) LBS.ByteString IO Void () @@ -159,7 +160,7 @@ runDataPointsAcceptor :: TracerEnv -> DPF.AcceptorConfiguration -> (ConnectionId LocalAddress -> IO ()) - -> RunMiniProtocol 'ResponderMode initiatorCtx (ResponderContext LocalAddress) LBS.ByteString IO Void () + -> RunMiniProtocol 'Mux.ResponderMode initiatorCtx (ResponderContext LocalAddress) LBS.ByteString IO Void () runDataPointsAcceptor tracerEnv dpfConfig errorHandler = acceptDataPointsResp dpfConfig diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs b/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs index 661816863cf..fd33054e4cb 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs @@ -20,11 +20,12 @@ import Cardano.Tracer.Configuration (Verbosity (..)) import Cardano.Tracer.Test.TestSetup import Cardano.Tracer.Test.Utils import Cardano.Tracer.Utils +import qualified Network.Mux as Mux import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits) import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) import Ouroboros.Network.IOManager (IOManager, withIOManager) import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (..), - MiniProtocolNum (..), MuxMode (..), OuroborosApplication (..), + MiniProtocolNum (..), OuroborosApplication (..), RunMiniProtocol (..), miniProtocolLimits, miniProtocolNum, miniProtocolRun) import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, codecHandshake, noTimeLimitsHandshake) @@ -33,21 +34,22 @@ import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion simpleSingletonVersions) import Ouroboros.Network.Snocket (MakeBearer, Snocket, localAddressFromPath, localSnocket, makeLocalBearer) -import Ouroboros.Network.Socket (AcceptedConnectionsLimit (..), HandshakeCallbacks (..), - SomeResponderApplication (..), cleanNetworkMutableState, connectToNode, - newNetworkMutableState, nullNetworkConnectTracers, nullNetworkServerTracers, - withServerNode) +import Ouroboros.Network.Socket (AcceptedConnectionsLimit (..), ConnectToArgs (..), + HandshakeCallbacks (..), SomeResponderApplication (..), cleanNetworkMutableState, + connectToNode, newNetworkMutableState, nullNetworkConnectTracers, + nullNetworkServerTracers, withServerNode) import Codec.CBOR.Term (Term) import Control.Concurrent (threadDelay) import Control.Concurrent.Async import Control.DeepSeq (NFData) +import Control.Exception (throwIO) import Control.Monad (forever) import "contra-tracer" Control.Tracer (contramap, nullTracer, stdoutTracer) import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString.Lazy as LBS import Data.Time.Clock (getCurrentTime) -import Data.Void (Void) +import Data.Void (Void, absurd) import Data.Word (Word16) import GHC.Generics import System.Directory @@ -157,15 +159,11 @@ doConnectToAcceptor TestSetup{..} snocket muxBearer address timeLimits (ekgConfi dpStore <- initDataPointStore writeToStore dpStore "test.data.point" $ DataPoint mkTestDataPoint withAsync (traceObjectsWriter sink) $ \_ -> do - connectToNode + done <- connectToNode snocket muxBearer + args mempty - (codecHandshake forwardingVersionCodec) - timeLimits - (cborTermVersionDataCodec forwardingCodecCBORTerm) - nullNetworkConnectTracers - (HandshakeCallbacks acceptableVersion queryVersion) (simpleSingletonVersions ForwardingV_1 (ForwardingVersionData $ unI tsNetworkMagic) @@ -177,10 +175,22 @@ doConnectToAcceptor TestSetup{..} snocket muxBearer address timeLimits (ekgConfi ) Nothing address + case done of + Left err -> throwIO err + Right choice -> case choice of + Left () -> return () + Right void -> absurd void where + args = ConnectToArgs { + ctaHandshakeCodec = codecHandshake forwardingVersionCodec, + ctaHandshakeTimeLimits = timeLimits, + ctaVersionDataCodec = cborTermVersionDataCodec forwardingCodecCBORTerm, + ctaConnectTracers = nullNetworkConnectTracers, + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } + forwarderApp - :: [(RunMiniProtocol 'InitiatorMode initCtx respCtx LBS.ByteString IO () Void, Word16)] - -> OuroborosApplication 'InitiatorMode initCtx respCtx LBS.ByteString IO () Void + :: [(RunMiniProtocol 'Mux.InitiatorMode initCtx respCtx LBS.ByteString IO () Void, Word16)] + -> OuroborosApplication 'Mux.InitiatorMode initCtx respCtx LBS.ByteString IO () Void forwarderApp protocols = OuroborosApplication [ MiniProtocol @@ -240,8 +250,8 @@ doListenToAcceptor TestSetup{..} $ \_ serverAsync -> wait serverAsync -- Block until async exception. where forwarderApp - :: [(RunMiniProtocol 'ResponderMode initCtx respCtx LBS.ByteString IO Void (), Word16)] - -> OuroborosApplication 'ResponderMode initCtx respCtx LBS.ByteString IO Void () + :: [(RunMiniProtocol 'Mux.ResponderMode initCtx respCtx LBS.ByteString IO Void (), Word16)] + -> OuroborosApplication 'Mux.ResponderMode initCtx respCtx LBS.ByteString IO Void () forwarderApp protocols = OuroborosApplication [ MiniProtocol diff --git a/configuration/cardano/mainnet-config.json b/configuration/cardano/mainnet-config.json index 75d872ae24e..7293475ac84 100644 --- a/configuration/cardano/mainnet-config.json +++ b/configuration/cardano/mainnet-config.json @@ -16,6 +16,7 @@ "RequiresNetworkMagic": "RequiresNoMagic", "ShelleyGenesisFile": "mainnet-shelley-genesis.json", "ShelleyGenesisHash": "1a3be38bcbb7911969283716ad7aa550250226b76a61fc51cc9a9a35d9276d81", + "ConsensusMode": "PraosMode", "TargetNumberOfActivePeers": 20, "TargetNumberOfEstablishedPeers": 50, "TargetNumberOfKnownPeers": 150, diff --git a/configuration/cardano/mainnet-config.yaml b/configuration/cardano/mainnet-config.yaml index 3427468ed8f..1ca4d3139cc 100644 --- a/configuration/cardano/mainnet-config.yaml +++ b/configuration/cardano/mainnet-config.yaml @@ -12,7 +12,7 @@ ConwayGenesisHash: 15a199f895e461ec0ffc6dd4e4028af28a492ab4e806d39cb674c88f7643e ShelleyGenesisFile: mainnet-shelley-genesis.json ShelleyGenesisHash: 1a3be38bcbb7911969283716ad7aa550250226b76a61fc51cc9a9a35d9276d81 -EnableP2P: true +EnableP2P: True ##### Core protocol parameters ##### @@ -34,6 +34,7 @@ MaxKnownMajorProtocolVersion: 2 ##### Network Configuration ##### +ConsensusMode: PraosMode PeerSharing: True TargetNumberOfActivePeers: 20 TargetNumberOfEstablishedPeers: 50 diff --git a/configuration/cardano/shelley_qa-config.json b/configuration/cardano/shelley_qa-config.json index 925aefa76aa..2151c1908dc 100644 --- a/configuration/cardano/shelley_qa-config.json +++ b/configuration/cardano/shelley_qa-config.json @@ -17,6 +17,7 @@ "RequiresNetworkMagic": "RequiresMagic", "ShelleyGenesisFile": "shelley_qa-shelley-genesis.json", "ShelleyGenesisHash": "73a9f6bdb0aa97f5e63190a6f14a702bd64a21f2bec831cbfc28f6037128b952", + "ConsensusMode": "PraosMode" "TargetNumberOfActivePeers": 20, "TargetNumberOfEstablishedPeers": 50, "TargetNumberOfKnownPeers": 150, diff --git a/flake.lock b/flake.lock index 78df0b9e78e..0ec4b248787 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1730295876, - "narHash": "sha256-ijnHTQ6eKIQ9FpEqDKt6c7vuFYN8aOBDhonp67utx2s=", + "lastModified": 1734535858, + "narHash": "sha256-9DzduMA63FdftXjZi5j2JKqxVnU8tC246w8N77MM1fs=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "25591f43ab943d5a070db5e8a2b9ff3a499d4d92", + "rev": "9cc1161fab9bafb3d6b7ee28395a732519caf540", "type": "github" }, "original": { @@ -526,11 +526,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1729039425, - "narHash": "sha256-sIglYcw8Dacj4n0bRlUWo+NLkDMcVi6vtmKvUyG+ZrQ=", + "lastModified": 1733877006, + "narHash": "sha256-rNpSFS/ziUQBPgo6iAbKgU00yRpeCngv215TW0D+kCo=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "6dc43e5e01f113ce151056a8f94bce7bb2f13eb9", + "rev": "583f569545854160b6bc5606374bf5006a9f6929", "type": "github" }, "original": { diff --git a/nix/haskell.nix b/nix/haskell.nix index 3a0975211f8..4b37f166cf7 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -22,7 +22,7 @@ let name = "cardano-node"; compiler-nix-name = lib.mkDefault "ghc8107"; # extra-compilers - flake.variants = lib.genAttrs ["ghc96"] (x: {compiler-nix-name = x;}); + flake.variants = lib.genAttrs ["ghc96" "ghc98" "ghc910"] (x: {compiler-nix-name = x;}); cabalProjectLocal = '' repository cardano-haskell-packages-local url: file:${CHaP} diff --git a/trace-dispatcher/bench/trace-dispatcher-bench.hs b/trace-dispatcher/bench/trace-dispatcher-bench.hs index b8425e2af4c..89d25a53304 100644 --- a/trace-dispatcher/bench/trace-dispatcher-bench.hs +++ b/trace-dispatcher/bench/trace-dispatcher-bench.hs @@ -6,7 +6,7 @@ import Cardano.Logging.Test.Tracer import Cardano.Logging.Test.Types import Data.IORef -import System.Remote.Monitoring (forkServer) +import System.Remote.Monitoring.Wai (forkServer) import Criterion.Main diff --git a/trace-dispatcher/src/Cardano/Logging/Forwarding.hs b/trace-dispatcher/src/Cardano/Logging/Forwarding.hs index f23a8e7917e..22927406140 100644 --- a/trace-dispatcher/src/Cardano/Logging/Forwarding.hs +++ b/trace-dispatcher/src/Cardano/Logging/Forwarding.hs @@ -17,12 +17,13 @@ module Cardano.Logging.Forwarding import Cardano.Logging.Types import Cardano.Logging.Utils (runInLoop) import Cardano.Logging.Version +import qualified Network.Mux as Mux import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits) import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) import Ouroboros.Network.IOManager (IOManager) import Ouroboros.Network.Magic (NetworkMagic) import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (..), - MiniProtocolNum (..), MuxMode (..), OuroborosApplication (..), + MiniProtocolNum (..), OuroborosApplication (..), RunMiniProtocol (..), miniProtocolLimits, miniProtocolNum, miniProtocolRun) import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, codecHandshake, noTimeLimitsHandshake) @@ -31,18 +32,19 @@ import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion simpleSingletonVersions) import Ouroboros.Network.Snocket (MakeBearer, Snocket, localAddressFromPath, localSnocket, makeLocalBearer) -import Ouroboros.Network.Socket (AcceptedConnectionsLimit (..), HandshakeCallbacks (..), - SomeResponderApplication (..), cleanNetworkMutableState, connectToNode, - newNetworkMutableState, nullNetworkConnectTracers, nullNetworkServerTracers, - withServerNode) +import Ouroboros.Network.Socket (AcceptedConnectionsLimit (..), ConnectToArgs (..), + HandshakeCallbacks (..), SomeResponderApplication (..), cleanNetworkMutableState, + connectToNode, newNetworkMutableState, nullNetworkConnectTracers, + nullNetworkServerTracers, withServerNode) import Codec.CBOR.Term (Term) import Control.Concurrent.Async (async, race_, wait) import Control.Monad (void) +import Control.Exception (throwIO) import Control.Monad.IO.Class import "contra-tracer" Control.Tracer (Tracer, contramap, nullTracer, stdoutTracer) import qualified Data.ByteString.Lazy as LBS -import Data.Void (Void) +import Data.Void (Void, absurd) import Data.Word (Word16) import System.IO (hPutStrLn, stderr) import qualified System.Metrics as EKG @@ -196,15 +198,11 @@ doConnectToAcceptor -> IO () doConnectToAcceptor magic snocket makeBearer configureSocket address timeLimits ekgConfig tfConfig dpfConfig sink ekgStore dpStore = do - connectToNode + done <- connectToNode snocket makeBearer + args configureSocket - (codecHandshake forwardingVersionCodec) - timeLimits - (cborTermVersionDataCodec forwardingCodecCBORTerm) - nullNetworkConnectTracers - (HandshakeCallbacks acceptableVersion queryVersion) (simpleSingletonVersions ForwardingV_1 (ForwardingVersionData magic) @@ -216,10 +214,21 @@ doConnectToAcceptor magic snocket makeBearer configureSocket address timeLimits ) Nothing address + case done of + Left err -> throwIO err + Right choice -> case choice of + Left () -> return () + Right v -> absurd v where + args = ConnectToArgs { + ctaHandshakeCodec = codecHandshake forwardingVersionCodec, + ctaHandshakeTimeLimits = timeLimits, + ctaVersionDataCodec = cborTermVersionDataCodec forwardingCodecCBORTerm, + ctaConnectTracers = nullNetworkConnectTracers, + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } forwarderApp - :: [(RunMiniProtocol 'InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void, Word16)] - -> OuroborosApplication 'InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void + :: [(RunMiniProtocol 'Mux.InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void, Word16)] + -> OuroborosApplication 'Mux.InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void forwarderApp protocols = OuroborosApplication [ MiniProtocol @@ -281,8 +290,8 @@ doListenToAcceptor magic snocket makeBearer configureSocket address timeLimits wait serverAsync -- Block until async exception. where forwarderApp - :: [(RunMiniProtocol 'ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void (), Word16)] - -> OuroborosApplication 'ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () + :: [(RunMiniProtocol 'Mux.ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void (), Word16)] + -> OuroborosApplication 'Mux.ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () forwarderApp protocols = OuroborosApplication [ MiniProtocol diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs index ba2060e34bf..c5f64226502 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs @@ -19,7 +19,7 @@ import qualified System.Metrics as Metrics import qualified System.Metrics.Counter as Counter import qualified System.Metrics.Gauge as Gauge import qualified System.Metrics.Label as Label -import System.Remote.Monitoring (Server, getCounter, getGauge, getLabel) +import System.Remote.Monitoring.Wai (Server, getCounter, getGauge, getLabel) -- | It is mandatory to construct only one standard tracer in any application! diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal index 09f155b25c6..968074f642f 100644 --- a/trace-dispatcher/trace-dispatcher.cabal +++ b/trace-dispatcher/trace-dispatcher.cabal @@ -54,13 +54,14 @@ library , containers , contra-tracer , deepseq - , ekg + , ekg-wai , ekg-core , ekg-forward >= 0.5 , hostname , network + , network-mux , optparse-applicative-fork - , ouroboros-network ^>= 0.17 + , ouroboros-network ^>= 0.18 , ouroboros-network-api , ouroboros-network-framework , serialise @@ -116,7 +117,6 @@ test-suite trace-dispatcher-test , cardano-prelude , containers , deepseq - , ekg , ekg-core , generic-data , hostname @@ -164,7 +164,7 @@ benchmark trace-dispatcher-bench , aeson , containers , criterion - , ekg + , ekg-wai , text , time , trace-dispatcher diff --git a/trace-forward/CHANGELOG.md b/trace-forward/CHANGELOG.md index 17819411f08..ff76eda49a7 100644 --- a/trace-forward/CHANGELOG.md +++ b/trace-forward/CHANGELOG.md @@ -1,5 +1,9 @@ # ChangeLog +## NEXT + +* Updated to `typed-protocols-0.3`. + ## 2.2.8 - Oct 2024 * Bump for version bound diff --git a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs index db5cf3e7fe0..7e5849af735 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -14,8 +15,7 @@ module Trace.Forward.Protocol.DataPoint.Acceptor , dataPointAcceptorPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), PeerRole (..)) - +import Network.TypedProtocol.Peer.Client import Trace.Forward.Protocol.DataPoint.Type data DataPointAcceptor m a where @@ -33,22 +33,22 @@ data DataPointAcceptor m a where dataPointAcceptorPeer :: Monad m => DataPointAcceptor m a - -> Peer DataPointForward 'AsClient 'StIdle m a + -> Client DataPointForward 'NonPipelined 'StIdle m a dataPointAcceptorPeer = \case SendMsgDataPointsRequest request next -> -- Send our message (request for new 'DataPoint's from the forwarder). - Yield (ClientAgency TokIdle) (MsgDataPointsRequest request) $ + Yield (MsgDataPointsRequest request) do -- We're now into the 'StBusy' state, and now we'll wait for a reply -- from the forwarder. It is assuming that the forwarder will reply -- immediately (even there are no 'DataPoint's). - Await (ServerAgency TokBusy) $ \(MsgDataPointsReply reply) -> - Effect $ + Await \(MsgDataPointsReply reply) -> + Effect do dataPointAcceptorPeer <$> next reply SendMsgDone getResult -> -- We do an actual transition using 'yield', to go from the 'StIdle' to -- 'StDone' state. Once in the 'StDone' state we can actually stop using -- 'done', with a return value. - Effect $ - Yield (ClientAgency TokIdle) MsgDone . Done TokDone + Effect do + Yield MsgDone . Done <$> getResult diff --git a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Codec.hs b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Codec.hs index b339c3f989b..c6ba7808cb6 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Codec.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Codec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -13,8 +14,7 @@ import qualified Codec.CBOR.Encoding as CBOR import Codec.CBOR.Read (DeserialiseFailure) import Control.Monad.Class.MonadST (MonadST) import qualified Data.ByteString.Lazy as LBS -import Network.TypedProtocol.Codec (Codec, PeerHasAgency (..), PeerRole (..), - SomeMessage (..)) +import Network.TypedProtocol.Codec import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS) import Text.Printf (printf) @@ -31,52 +31,52 @@ codecDataPointForward DeserialiseFailure m LBS.ByteString codecDataPointForward encodeRequest decodeRequest encodeReplyList decodeReplyList = - mkCodecCborLazyBS encode decode + mkCodecCborLazyBS encode' decode' where -- Encode messages. - encode - :: forall (pr :: PeerRole) - (st :: DataPointForward) + encode' + :: forall (st :: DataPointForward) (st' :: DataPointForward). - PeerHasAgency pr st - -> Message DataPointForward st st' + Message DataPointForward st st' -> CBOR.Encoding - encode (ClientAgency TokIdle) (MsgDataPointsRequest request) = + encode' (MsgDataPointsRequest request) = CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> encodeRequest request - encode (ClientAgency TokIdle) MsgDone = + encode' MsgDone = CBOR.encodeListLen 1 <> CBOR.encodeWord 2 - encode (ServerAgency TokBusy) (MsgDataPointsReply reply) = + encode' (MsgDataPointsReply reply) = CBOR.encodeListLen 2 <> CBOR.encodeWord 3 <> encodeReplyList reply -- Decode messages - decode - :: forall (pr :: PeerRole) - (st :: DataPointForward) s. - PeerHasAgency pr st + decode' + :: forall (st :: DataPointForward) s. + ActiveState st + => StateToken st -> CBOR.Decoder s (SomeMessage st) - decode stok = do + decode' stok = do len <- CBOR.decodeListLen key <- CBOR.decodeWord case (key, len, stok) of - (1, 2, ClientAgency TokIdle) -> + (1, 2, SingIdle) -> SomeMessage . MsgDataPointsRequest <$> decodeRequest - (2, 1, ClientAgency TokIdle) -> + (2, 1, SingIdle) -> return $ SomeMessage MsgDone - (3, 2, ServerAgency TokBusy) -> + (3, 2, SingBusy) -> SomeMessage . MsgDataPointsReply <$> decodeReplyList -- Failures per protocol state - (_, _, ClientAgency TokIdle) -> + (_, _, SingIdle) -> fail (printf "codecDataPointForward (%s) unexpected key (%d, %d)" (show stok) key len) - (_, _, ServerAgency TokBusy) -> + (_, _, SingBusy) -> fail (printf "codecDataPointForward (%s) unexpected key (%d, %d)" (show stok) key len) + + (_, _, SingDone) -> notActiveState stok diff --git a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs index b4b8e34f6df..84cad1da407 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -9,7 +10,7 @@ module Trace.Forward.Protocol.DataPoint.Forwarder , dataPointForwarderPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), PeerRole (..)) +import Network.TypedProtocol.Peer.Server import Trace.Forward.Protocol.DataPoint.Type @@ -29,22 +30,21 @@ data DataPointForwarder m a = DataPointForwarder dataPointForwarderPeer :: Monad m => DataPointForwarder m a - -> Peer DataPointForward 'AsServer 'StIdle m a + -> Server DataPointForward 'NonPipelined 'StIdle m a dataPointForwarderPeer DataPointForwarder{recvMsgDataPointsRequest, recvMsgDone} = go where go = -- In the 'StIdle' state the forwarder is awaiting a request message -- from the acceptor. - Await (ClientAgency TokIdle) $ \case + Await \case -- The acceptor sent us a request for new 'DataPoint's, so now we're -- in the 'StBusy' state which means it's the forwarder's turn to send -- a reply. - MsgDataPointsRequest request -> Effect $ do + MsgDataPointsRequest request -> Effect do reply <- recvMsgDataPointsRequest request - return $ Yield (ServerAgency TokBusy) - (MsgDataPointsReply reply) + return $ Yield (MsgDataPointsReply reply) go -- The acceptor sent the done transition, so we're in the 'StDone' state -- so all we can do is stop using 'done', with a return value. - MsgDone -> Effect $ Done TokDone <$> recvMsgDone + MsgDone -> Effect $ Done <$> recvMsgDone diff --git a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs index c3d493222bd..9a54c4cc507 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs @@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} -- | The type of the 'DataPoint' forwarding/accepting protocol. @@ -14,16 +16,16 @@ module Trace.Forward.Protocol.DataPoint.Type , DataPointValues , DataPointForward (..) , Message (..) - , ClientHasAgency (..) - , ServerHasAgency (..) - , NobodyHasAgency (..) + , SingDataPointForward (..) ) where +import Data.Singletons +import Network.TypedProtocol.Core import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) import qualified Data.ByteString.Lazy as LBS +import Data.Kind (Type) import Data.Text (Text) -import Network.TypedProtocol.Core (Protocol (..)) -- | A kind to identify our protocol, and the types of the states in the state -- transition diagram of the protocol. @@ -62,6 +64,25 @@ data DataPointForward where instance ShowProxy DataPointForward where showProxy _ = "DataPointForward" +-- | Singleton type of DataPointForward. Same as: +-- +-- @ +-- type SingDataPointForward :: DataPointForward -> Type +-- type SingDataPointForward = TypeRep +-- @ +type SingDataPointForward :: DataPointForward -> Type +data SingDataPointForward dataPoint where + SingIdle :: SingDataPointForward 'StIdle + SingBusy :: SingDataPointForward 'StBusy + SingDone :: SingDataPointForward 'StDone + +type instance Sing = SingDataPointForward + +deriving instance Show (SingDataPointForward st) +instance StateTokenI 'StIdle where stateToken = SingIdle +instance StateTokenI 'StBusy where stateToken = SingBusy +instance StateTokenI 'StDone where stateToken = SingDone + instance Protocol DataPointForward where -- | The messages in the trace forwarding/accepting protocol. @@ -95,27 +116,11 @@ instance Protocol DataPointForward where -- 1. ClientHasAgency (from 'Network.TypedProtocol.Core') corresponds to acceptor's agency. -- 3. ServerHasAgency (from 'Network.TypedProtocol.Core') corresponds to forwarder's agency. -- - data ClientHasAgency st where - TokIdle :: ClientHasAgency 'StIdle - - data ServerHasAgency st where - TokBusy :: ServerHasAgency 'StBusy - - data NobodyHasAgency st where - TokDone :: NobodyHasAgency 'StDone - - -- | Impossible cases. - exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {} - exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {} - exclusionLemma_NobodyAndServerHaveAgency TokDone tok = case tok of {} - -instance Show (Message DataPointForward from to) where - show MsgDataPointsRequest{} = "MsgDataPointsRequest" - show MsgDataPointsReply{} = "MsgDataPointsReply" - show MsgDone{} = "MsgDone" + type StateAgency 'StIdle = 'ClientAgency + type StateAgency 'StBusy = 'ServerAgency + type StateAgency 'StDone = 'NobodyAgency -instance Show (ClientHasAgency (st :: DataPointForward)) where - show TokIdle = "TokIdle" + type StateToken = SingDataPointForward -instance Show (ServerHasAgency (st :: DataPointForward)) where - show TokBusy{} = "TokBusy" +deriving + instance Show (Message DataPointForward from to) diff --git a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs index 16b9ccddd36..4e5f567eede 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} -- | A view of the trace forwarding/accepting protocol -- from the point of view of the client. @@ -14,10 +16,12 @@ module Trace.Forward.Protocol.TraceObject.Acceptor , traceObjectAcceptorPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), PeerRole (..)) +import Data.Kind (Type) +import Network.TypedProtocol.Peer.Client import Trace.Forward.Protocol.TraceObject.Type +type TraceObjectAcceptor :: Type -> (Type -> Type) -> Type -> Type data TraceObjectAcceptor lo m a where SendMsgTraceObjectsRequest :: TokBlockingStyle blocking @@ -34,31 +38,31 @@ data TraceObjectAcceptor lo m a where traceObjectAcceptorPeer :: Monad m => TraceObjectAcceptor lo m a - -> Peer (TraceObjectForward lo) 'AsClient 'StIdle m a + -> Client (TraceObjectForward lo) 'NonPipelined 'StIdle m a traceObjectAcceptorPeer = \case SendMsgTraceObjectsRequest TokBlocking request next -> -- Send our message (request for new 'TraceObject's from the forwarder). - Yield (ClientAgency TokIdle) (MsgTraceObjectsRequest TokBlocking request) $ + Yield (MsgTraceObjectsRequest TokBlocking request) do -- We're now into the 'StBusy' state, and now we'll wait for a reply -- from the forwarder. - Await (ServerAgency (TokBusy TokBlocking)) $ \(MsgTraceObjectsReply reply) -> - Effect $ + Await \(MsgTraceObjectsReply reply) -> + Effect do traceObjectAcceptorPeer <$> next reply SendMsgTraceObjectsRequest TokNonBlocking request next -> -- Send our message (request for new 'TraceObject's from the forwarder). - Yield (ClientAgency TokIdle) (MsgTraceObjectsRequest TokNonBlocking request) $ + Yield (MsgTraceObjectsRequest TokNonBlocking request) do -- We're now into the 'StBusy' state, and now we'll wait for a reply -- from the forwarder. It is assuming that the forwarder will reply -- immediately (even there are no 'TraceObject's). - Await (ServerAgency (TokBusy TokNonBlocking)) $ \(MsgTraceObjectsReply reply) -> - Effect $ + Await \(MsgTraceObjectsReply reply) -> + Effect do traceObjectAcceptorPeer <$> next reply SendMsgDone getResult -> -- We do an actual transition using 'yield', to go from the 'StIdle' to -- 'StDone' state. Once in the 'StDone' state we can actually stop using -- 'done', with a return value. - Effect $ - Yield (ClientAgency TokIdle) MsgDone . Done TokDone + Effect do + Yield MsgDone . Done <$> getResult diff --git a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Codec.hs b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Codec.hs index 31fc7edea91..5af9b9be92d 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Codec.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Codec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -14,8 +15,7 @@ import Codec.CBOR.Read (DeserialiseFailure) import Control.Monad.Class.MonadST (MonadST) import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE -import Network.TypedProtocol.Codec (Codec, PeerHasAgency (..), PeerRole (..), - SomeMessage (..)) +import Network.TypedProtocol.Codec (Codec, ActiveState, StateToken, notActiveState, SomeMessage (..)) import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS) import Text.Printf (printf) @@ -36,14 +36,13 @@ codecTraceObjectForward encodeRequest decodeRequest where -- Encode messages. encode - :: forall (pr :: PeerRole) - (st :: TraceObjectForward lo) + :: forall (st :: TraceObjectForward lo) (st' :: TraceObjectForward lo). - PeerHasAgency pr st - -> Message (TraceObjectForward lo) st st' + Message (TraceObjectForward lo) st st' -> CBOR.Encoding - encode (ClientAgency TokIdle) (MsgTraceObjectsRequest blocking request) = + + encode (MsgTraceObjectsRequest blocking request) = CBOR.encodeListLen 3 <> CBOR.encodeWord 1 <> CBOR.encodeBool (case blocking of @@ -51,11 +50,11 @@ codecTraceObjectForward encodeRequest decodeRequest TokNonBlocking -> False) <> encodeRequest request - encode (ClientAgency TokIdle) MsgDone = + encode MsgDone = CBOR.encodeListLen 1 <> CBOR.encodeWord 2 - encode (ServerAgency (TokBusy _)) (MsgTraceObjectsReply reply) = + encode (MsgTraceObjectsReply reply) = CBOR.encodeListLen 2 <> CBOR.encodeWord 3 <> encodeReplyList replyList @@ -67,15 +66,15 @@ codecTraceObjectForward encodeRequest decodeRequest -- Decode messages decode - :: forall (pr :: PeerRole) - (st :: TraceObjectForward lo) s. - PeerHasAgency pr st + :: forall (st :: TraceObjectForward lo) s. + ActiveState st + => StateToken st -> CBOR.Decoder s (SomeMessage st) - decode stok = do + decode stateToken = do len <- CBOR.decodeListLen key <- CBOR.decodeWord - case (key, len, stok) of - (1, 3, ClientAgency TokIdle) -> do + case (key, len, stateToken) of + (1, 3, SingIdle) -> do blocking <- CBOR.decodeBool request <- decodeRequest return $! @@ -84,10 +83,10 @@ codecTraceObjectForward encodeRequest decodeRequest else SomeMessage $ MsgTraceObjectsRequest TokNonBlocking request - (2, 1, ClientAgency TokIdle) -> + (2, 1, SingIdle) -> return $ SomeMessage MsgDone - (3, 2, ServerAgency (TokBusy blocking)) -> do + (3, 2, SingBusy blocking) -> do replyList <- decodeReplyList case (blocking, replyList) of (TokBlocking, x:xs) -> @@ -100,9 +99,10 @@ codecTraceObjectForward encodeRequest decodeRequest fail "codecTraceObjectForward: MsgTraceObjectsReply: empty list not permitted" -- Failures per protocol state - (_, _, ClientAgency TokIdle) -> - fail (printf "codecTraceObjectForward (%s) unexpected key (%d, %d)" (show stok) key len) - (_, _, ServerAgency (TokBusy TokBlocking)) -> - fail (printf "codecTraceObjectForward (%s) unexpected key (%d, %d)" (show stok) key len) - (_, _, ServerAgency (TokBusy TokNonBlocking)) -> - fail (printf "codecTraceObjectForward (%s) unexpected key (%d, %d)" (show stok) key len) + (_, _, SingIdle) -> + fail (printf "codecTraceObjectForward (%s) unexpected key (%d, %d)" (show stateToken) key len) + (_, _, SingBusy TokBlocking) -> + fail (printf "codecTraceObjectForward (%s) unexpected key (%d, %d)" (show stateToken) key len) + (_, _, SingBusy TokNonBlocking) -> + fail (printf "codecTraceObjectForward (%s) unexpected key (%d, %d)" (show stateToken) key len) + (_, _, SingDone) -> notActiveState stateToken diff --git a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs index 5e951308c6d..b71046f08e8 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs @@ -1,15 +1,20 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Trace.Forward.Protocol.TraceObject.Forwarder ( TraceObjectForwarder (..) , traceObjectForwarderPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), PeerRole (..)) +import Data.Singletons +import Network.TypedProtocol.Peer.Server +-- import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), PeerRole (..)) import Trace.Forward.Protocol.TraceObject.Type @@ -30,24 +35,27 @@ data TraceObjectForwarder lo m a = TraceObjectForwarder -- | Interpret a particular action sequence into the server side of the protocol. -- traceObjectForwarderPeer - :: Monad m + :: forall m lo a + . Monad m => TraceObjectForwarder lo m a - -> Peer (TraceObjectForward lo) 'AsServer 'StIdle m a + -> Server (TraceObjectForward lo) 'NonPipelined 'StIdle m a traceObjectForwarderPeer TraceObjectForwarder{recvMsgTraceObjectsRequest, recvMsgDone} = go where - go = - -- In the 'StIdle' state the forwarder is awaiting a request message - -- from the acceptor. - Await (ClientAgency TokIdle) $ \case - -- The acceptor sent us a request for new 'TraceObject's, so now we're - -- in the 'StBusy' state which means it's the forwarder's turn to send - -- a reply. - MsgTraceObjectsRequest blocking request -> Effect $ do - reply <- recvMsgTraceObjectsRequest blocking request - return $ Yield (ServerAgency (TokBusy blocking)) - (MsgTraceObjectsReply reply) - go - - -- The acceptor sent the done transition, so we're in the 'StDone' state - -- so all we can do is stop using 'done', with a return value. - MsgDone -> Effect $ Done TokDone <$> recvMsgDone + go :: Server (TraceObjectForward lo) 'NonPipelined StIdle m a + go = + -- In the 'StIdle' state the forwarder is awaiting a request message + -- from the acceptor. + Await \case + -- The acceptor sent us a request for new 'TraceObject's, so now we're + -- in the 'StBusy' state which means it's the forwarder's turn to send + -- a reply. + MsgTraceObjectsRequest blocking request -> Effect do + reply <- recvMsgTraceObjectsRequest blocking request + pure do + withSingI blocking do + Yield (MsgTraceObjectsReply reply) go + + -- The acceptor sent the done transition, so we're in the 'StDone' state + -- so all we can do is stop using 'done', with a return value. + MsgDone -> Effect do + Done <$> recvMsgDone diff --git a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs index 0419f268dcf..16b7536de48 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs @@ -1,11 +1,14 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} -- | The type of the trace forwarding/accepting protocol. @@ -13,23 +16,23 @@ module Trace.Forward.Protocol.TraceObject.Type ( TraceObjectForward (..) + , SingTraceObjectForward(..) , TokBlockingStyle (..) , Message (..) - , ClientHasAgency (..) - , ServerHasAgency (..) - , NobodyHasAgency (..) , NumberOfTraceObjects (..) , BlockingReplyList (..) + , StBlockingStyle(..) ) where import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) +import Data.Kind (Type) +import Data.Singletons import Codec.Serialise (Serialise (..)) import Data.List.NonEmpty (NonEmpty) -import Data.Proxy (Proxy (..)) import Data.Word (Word16) import GHC.Generics (Generic) -import Network.TypedProtocol.Core (Protocol (..)) +import Network.TypedProtocol.Core -- (Protocol (..)) -- | A kind to identify our protocol, and the types of the states in the state -- transition diagram of the protocol. @@ -49,10 +52,11 @@ import Network.TypedProtocol.Core (Protocol (..)) -- | The acceptor will send this request to the forwarder. newtype NumberOfTraceObjects = NumberOfTraceObjects { nTraceObjects :: Word16 - } deriving (Eq, Generic, Show) - -instance ShowProxy NumberOfTraceObjects -instance Serialise NumberOfTraceObjects + } + deriving stock + (Eq, Generic, Show) + deriving anyclass + (ShowProxy, Serialise) data TraceObjectForward lo where @@ -84,6 +88,13 @@ instance (ShowProxy lo) , ")" ] +-- | Singleton type of TraceObjectForward. +type SingTraceObjectForward :: TraceObjectForward lo -> Type +data SingTraceObjectForward traceObj where + SingIdle :: SingTraceObjectForward 'StIdle + SingBusy :: TokBlockingStyle blockStyle -> SingTraceObjectForward ('StBusy blockStyle) + SingDone :: SingTraceObjectForward 'StDone + data StBlockingStyle where -- | In this sub-state the reply need not be prompt. There is no timeout. StBlocking :: StBlockingStyle @@ -101,6 +112,18 @@ data TokBlockingStyle (k :: StBlockingStyle) where deriving instance Eq (TokBlockingStyle b) deriving instance Show (TokBlockingStyle b) +type instance Sing = SingTraceObjectForward +type instance Sing = TokBlockingStyle + +deriving stock + instance Show (SingTraceObjectForward traceObj) +instance StateTokenI 'StIdle where stateToken = SingIdle +instance StateTokenI 'StDone where stateToken = SingDone +instance SingI blockStyle => StateTokenI ('StBusy blockStyle) where stateToken = SingBusy sing + +instance SingI 'StBlocking where sing = TokBlocking +instance SingI 'StNonBlocking where sing = TokNonBlocking + -- | We have requests for lists of things. In the blocking case the -- corresponding reply must be non-empty, whereas in the non-blocking case -- an empty reply is fine. @@ -154,28 +177,11 @@ instance Protocol (TraceObjectForward lo) where -- 1. ClientHasAgency (from 'Network.TypedProtocol.Core') corresponds to acceptor's agency. -- 3. ServerHasAgency (from 'Network.TypedProtocol.Core') corresponds to forwarder's agency. -- - data ClientHasAgency st where - TokIdle :: ClientHasAgency 'StIdle - - data ServerHasAgency st where - TokBusy :: TokBlockingStyle blocking -> ServerHasAgency ('StBusy blocking) - - data NobodyHasAgency st where - TokDone :: NobodyHasAgency 'StDone - - -- | Impossible cases. - exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {} - exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {} - exclusionLemma_NobodyAndServerHaveAgency TokDone tok = case tok of {} - -instance Show lo - => Show (Message (TraceObjectForward lo) from to) where - show MsgTraceObjectsRequest{} = "MsgTraceObjectsRequest" - show MsgTraceObjectsReply{} = "MsgTraceObjectsReply" - show MsgDone{} = "MsgDone" + type StateAgency 'StIdle = 'ClientAgency + type StateAgency ('StBusy blocking) = 'ServerAgency + type StateAgency 'StDone = 'NobodyAgency -instance Show (ClientHasAgency (st :: TraceObjectForward lo)) where - show TokIdle = "TokIdle" + type StateToken = SingTraceObjectForward -instance Show (ServerHasAgency (st :: TraceObjectForward lo)) where - show TokBusy{} = "TokBusy" +deriving stock + instance Show lo => Show (Message (TraceObjectForward lo) from to) diff --git a/trace-forward/src/Trace/Forward/Run/DataPoint/Acceptor.hs b/trace-forward/src/Trace/Forward/Run/DataPoint/Acceptor.hs index 16237daa7b9..5131d36efed 100644 --- a/trace-forward/src/Trace/Forward/Run/DataPoint/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Run/DataPoint/Acceptor.hs @@ -6,8 +6,9 @@ module Trace.Forward.Run.DataPoint.Acceptor , acceptDataPointsResp ) where +import qualified Network.Mux as Mux import Ouroboros.Network.Driver.Simple (runPeer) -import Ouroboros.Network.Mux (MiniProtocolCb (..), MuxMode (..), RunMiniProtocol (..)) +import Ouroboros.Network.Mux (MiniProtocolCb (..), RunMiniProtocol (..)) import qualified Codec.Serialise as CBOR import Control.Concurrent.STM.TMVar (putTMVar) @@ -29,7 +30,7 @@ acceptDataPointsInit :: AcceptorConfiguration -> (initiatorCtx -> IO DataPointRequestor) -> (initiatorCtx -> IO ()) - -> RunMiniProtocol 'InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void + -> RunMiniProtocol 'Mux.InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void acceptDataPointsInit config mkDPRequestor peerErrorHandler = InitiatorProtocolOnly $ runPeerWithRequestor config mkDPRequestor peerErrorHandler @@ -37,7 +38,7 @@ acceptDataPointsResp :: AcceptorConfiguration -> (responderCtx -> IO DataPointRequestor) -> (responderCtx -> IO ()) - -> RunMiniProtocol 'ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () + -> RunMiniProtocol 'Mux.ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () acceptDataPointsResp config mkDPRequestor peerErrorHandler = ResponderProtocolOnly $ runPeerWithRequestor config mkDPRequestor peerErrorHandler diff --git a/trace-forward/src/Trace/Forward/Run/DataPoint/Forwarder.hs b/trace-forward/src/Trace/Forward/Run/DataPoint/Forwarder.hs index bbffc9c58fd..3a8537540f3 100644 --- a/trace-forward/src/Trace/Forward/Run/DataPoint/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Run/DataPoint/Forwarder.hs @@ -5,8 +5,9 @@ module Trace.Forward.Run.DataPoint.Forwarder , forwardDataPointsResp ) where +import qualified Network.Mux as Mux import Ouroboros.Network.Driver.Simple (runPeer) -import Ouroboros.Network.Mux (MiniProtocolCb (..), MuxMode (..), RunMiniProtocol (..)) +import Ouroboros.Network.Mux (MiniProtocolCb (..), RunMiniProtocol (..)) import qualified Codec.Serialise as CBOR import qualified Data.ByteString.Lazy as LBS @@ -20,14 +21,14 @@ import Trace.Forward.Utils.DataPoint forwardDataPointsInit :: ForwarderConfiguration -> DataPointStore - -> RunMiniProtocol 'InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void + -> RunMiniProtocol 'Mux.InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void forwardDataPointsInit config dpStore = InitiatorProtocolOnly $ runPeerWithDPStore config dpStore forwardDataPointsResp :: ForwarderConfiguration -> DataPointStore - -> RunMiniProtocol 'ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () + -> RunMiniProtocol 'Mux.ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () forwardDataPointsResp config dpStore = ResponderProtocolOnly $ runPeerWithDPStore config dpStore diff --git a/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs b/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs index 5acf265a0db..df161659551 100644 --- a/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs @@ -8,8 +8,9 @@ module Trace.Forward.Run.TraceObject.Acceptor , acceptTraceObjectsResp ) where +import qualified Network.Mux as Mux import Ouroboros.Network.Driver.Simple (runPeer) -import Ouroboros.Network.Mux (MiniProtocolCb (..), MuxMode (..), RunMiniProtocol (..)) +import Ouroboros.Network.Mux (MiniProtocolCb (..), RunMiniProtocol (..)) import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) import qualified Codec.Serialise as CBOR @@ -35,7 +36,7 @@ acceptTraceObjectsInit => AcceptorConfiguration lo -- ^ Acceptor's configuration. -> (initiatorCtx -> [lo] -> IO ()) -- ^ The handler for accepted 'TraceObject's. -> (initiatorCtx -> IO ()) -- ^ The handler for exceptions from 'runPeer'. - -> RunMiniProtocol 'InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void + -> RunMiniProtocol 'Mux.InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void acceptTraceObjectsInit config loHandler peerErrorHandler = InitiatorProtocolOnly $ runPeerWithHandler config loHandler peerErrorHandler @@ -46,7 +47,7 @@ acceptTraceObjectsResp => AcceptorConfiguration lo -- ^ Acceptor's configuration. -> (responderCtx -> [lo] -> IO ()) -- ^ The handler for accepted 'TraceObject's. -> (responderCtx -> IO ()) -- ^ The handler for exceptions from 'runPeer'. - -> RunMiniProtocol 'ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () + -> RunMiniProtocol 'Mux.ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () acceptTraceObjectsResp config loHandler peerErrorHandler = do ResponderProtocolOnly $ runPeerWithHandler config loHandler peerErrorHandler diff --git a/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs b/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs index 8d9308c0f2a..bd460ba36c7 100644 --- a/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs @@ -5,8 +5,9 @@ module Trace.Forward.Run.TraceObject.Forwarder , forwardTraceObjectsResp ) where +import qualified Network.Mux as Mux import Ouroboros.Network.Driver.Simple (runPeer) -import Ouroboros.Network.Mux (MiniProtocolCb (..), MuxMode (..), RunMiniProtocol (..)) +import Ouroboros.Network.Mux (MiniProtocolCb (..), RunMiniProtocol (..)) import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) import qualified Codec.Serialise as CBOR @@ -23,7 +24,7 @@ forwardTraceObjectsInit ShowProxy lo) => ForwarderConfiguration lo -> ForwardSink lo - -> RunMiniProtocol 'InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void + -> RunMiniProtocol 'Mux.InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void forwardTraceObjectsInit config sink = InitiatorProtocolOnly $ runPeerWithSink config sink @@ -32,7 +33,7 @@ forwardTraceObjectsResp ShowProxy lo) => ForwarderConfiguration lo -> ForwardSink lo - -> RunMiniProtocol 'ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () + -> RunMiniProtocol 'Mux.ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () forwardTraceObjectsResp config sink = ResponderProtocolOnly $ runPeerWithSink config sink diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs index 7162a7c4d3f..30c0af3491a 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs @@ -12,12 +12,12 @@ import Test.Trace.Forward.Protocol.DataPoint.Item import Trace.Forward.Protocol.DataPoint.Type -instance Arbitrary (AnyMessageAndAgency DataPointForward) where +instance Arbitrary (AnyMessage DataPointForward) where arbitrary = oneof - [ pure $ AnyMessageAndAgency (ClientAgency TokIdle) (MsgDataPointsRequest ["NodeInfo"]) - , pure $ AnyMessageAndAgency (ServerAgency TokBusy) (MsgDataPointsReply [("NodeInfo", Nothing)]) - , pure $ AnyMessageAndAgency (ServerAgency TokBusy) (MsgDataPointsReply [("NodeInfo", Just ni)]) - , pure $ AnyMessageAndAgency (ClientAgency TokIdle) MsgDone + [ pure $ AnyMessage (MsgDataPointsRequest ["NodeInfo"]) + , pure $ AnyMessage (MsgDataPointsReply [("NodeInfo", Nothing)]) + , pure $ AnyMessage (MsgDataPointsReply [("NodeInfo", Just ni)]) + , pure $ AnyMessage MsgDone ] where ni = A.encode $ TestNodeInfo diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs index 386ec12b607..59d8b9ad487 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs @@ -44,7 +44,7 @@ tests = testGroup "Trace.Forward.Protocol.DataPoint" ] prop_codec_DataPointForward - :: AnyMessageAndAgency DataPointForward + :: AnyMessage DataPointForward -> Bool prop_codec_DataPointForward msg = runST $ prop_codecM @@ -53,7 +53,7 @@ prop_codec_DataPointForward msg = runST $ msg prop_codec_splits2_DataPointForward - :: AnyMessageAndAgency DataPointForward + :: AnyMessage DataPointForward -> Bool prop_codec_splits2_DataPointForward msg = runST $ prop_codec_splitsM @@ -64,7 +64,7 @@ prop_codec_splits2_DataPointForward msg = runST $ prop_codec_splits3_DataPointForward - :: AnyMessageAndAgency DataPointForward + :: AnyMessage DataPointForward -> Bool prop_codec_splits3_DataPointForward msg = runST $ prop_codec_splitsM @@ -108,7 +108,7 @@ prop_connect f n = do forwarder <- dataPointForwarderPeer <$> dataPointForwarderCount result <- connect forwarder (dataPointAcceptorPeer $ dataPointAcceptorApply f 0 n) case result of - (s, c, TerminalStates TokDone TokDone) -> + (s, c, TerminalStates SingDone SingDone) -> pure $ (s, c) == (n, foldr ($) 0 (replicate n f)) prop_channel diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs index c5d4176dfbe..fb3aeaa8e25 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs @@ -17,13 +17,13 @@ instance Arbitrary NumberOfTraceObjects where , pure $ NumberOfTraceObjects 100 ] -instance Arbitrary (AnyMessageAndAgency (TraceObjectForward TraceItem)) where +instance Arbitrary (AnyMessage (TraceObjectForward TraceItem)) where arbitrary = oneof - [ AnyMessageAndAgency (ClientAgency TokIdle) . MsgTraceObjectsRequest TokBlocking <$> arbitrary - , AnyMessageAndAgency (ClientAgency TokIdle) . MsgTraceObjectsRequest TokNonBlocking <$> arbitrary - , AnyMessageAndAgency (ServerAgency (TokBusy TokBlocking)) . MsgTraceObjectsReply . BlockingReply <$> arbitrary - , AnyMessageAndAgency (ServerAgency (TokBusy TokNonBlocking)) . MsgTraceObjectsReply . NonBlockingReply <$> arbitrary - , pure $ AnyMessageAndAgency (ClientAgency TokIdle) MsgDone + [ AnyMessage . MsgTraceObjectsRequest TokBlocking <$> arbitrary + , AnyMessage . MsgTraceObjectsRequest TokNonBlocking <$> arbitrary + , AnyMessage . MsgTraceObjectsReply . BlockingReply <$> arbitrary + , AnyMessage . MsgTraceObjectsReply . NonBlockingReply <$> arbitrary + , pure $ AnyMessage MsgDone ] instance Eq (AnyMessage (TraceObjectForward TraceItem)) where diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs index 40a315d75e3..67ecbe9741f 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs @@ -43,7 +43,7 @@ tests = testGroup "Trace.Forward.Protocol.TraceObject" , testProperty "channel IO" prop_channel_IO_TraceObjectForward ] -prop_codec_TraceObjectForward :: AnyMessageAndAgency (TraceObjectForward TraceItem) -> Bool +prop_codec_TraceObjectForward :: AnyMessage (TraceObjectForward TraceItem) -> Bool prop_codec_TraceObjectForward msg = runST $ prop_codecM (codecTraceObjectForward CBOR.encode CBOR.decode @@ -51,7 +51,7 @@ prop_codec_TraceObjectForward msg = runST $ msg prop_codec_splits2_TraceObjectForward - :: AnyMessageAndAgency (TraceObjectForward TraceItem) + :: AnyMessage (TraceObjectForward TraceItem) -> Bool prop_codec_splits2_TraceObjectForward msg = runST $ prop_codec_splitsM @@ -61,7 +61,7 @@ prop_codec_splits2_TraceObjectForward msg = runST $ msg prop_codec_splits3_TraceObjectForward - :: AnyMessageAndAgency (TraceObjectForward TraceItem) + :: AnyMessage (TraceObjectForward TraceItem) -> Bool prop_codec_splits3_TraceObjectForward msg = runST $ prop_codec_splitsM @@ -105,7 +105,7 @@ prop_connect f n = do forwarder <- traceObjectForwarderPeer <$> traceObjectForwarderCount result <- connect forwarder (traceObjectAcceptorPeer $ traceObjectAcceptorApply f 0 n) case result of - (s, c, TerminalStates TokDone TokDone) -> + (s, c, TerminalStates SingDone SingDone) -> pure $ (s, c) == (n, foldr ($) 0 (replicate n f)) prop_channel diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal index fbce68d6d9a..5edc9a0e647 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -64,12 +64,14 @@ library , deepseq , extra , io-classes - , ouroboros-network-api ^>= 0.10 - , ouroboros-network-framework + , network-mux + , ouroboros-network-api + , singletons ^>= 3.0 + , ouroboros-network-framework ^>= 0.14 , serialise , stm , text - , typed-protocols ^>= 0.1 + , typed-protocols ^>= 0.3 , typed-protocols-cborg test-suite test