diff --git a/.gitattributes b/.gitattributes index 6370e879f22..5a706b986af 100644 --- a/.gitattributes +++ b/.gitattributes @@ -5,3 +5,5 @@ configuration/cardano/mainnet-alonzo-genesis.json text eol=lf configuration/cardano/mainnet-byron-genesis.json text eol=lf configuration/cardano/mainnet-conway-genesis.json text eol=lf configuration/cardano/mainnet-shelley-genesis.json text eol=lf +cardano-testnet/test/cardano-testnet-test/files/sample-proposal-anchor text eol=lf +cardano-testnet/test/cardano-testnet-test/files/sample-constitution-anchor text eol=lf diff --git a/bench/locli/locli.cabal b/bench/locli/locli.cabal index 5d2ee1aa961..7649407e988 100644 --- a/bench/locli/locli.cabal +++ b/bench/locli/locli.cabal @@ -119,7 +119,7 @@ library , hashable , optparse-applicative-fork >= 0.18.1 , ouroboros-consensus - , ouroboros-network-api ^>= 0.10 + , ouroboros-network-api ^>= 0.12 , sop-core , split , sqlite-easy >= 1.1.0.1 @@ -189,7 +189,7 @@ test-suite test-locli build-depends: cardano-prelude , containers , hedgehog - , hedgehog-extras ^>= 0.6.4 + , hedgehog-extras ^>= 0.7 , locli , text diff --git a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal index b548ac79948..4c6dc8ed805 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.6 + , 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/Benchmarking/Tracer.hs b/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs index f52fe4db709..b6427c938da 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} @@ -123,8 +124,8 @@ initTxGenTracers mbForwarding = do prepareForwardingTracer = forM mbForwarding $ \(iomgr, networkId, tracerSocket) -> do let forwardingConf = fromMaybe defaultForwarder (tcForwarder initialTraceConfig) - (forwardSink :: ForwardSink TraceObject, dpStore) <- - initForwarding iomgr forwardingConf (toNetworkMagic networkId) Nothing $ Just (tracerSocket, Initiator) + (forwardSink :: ForwardSink TraceObject, dpStore, kickoffForwarder) <- + initForwardingDelayed iomgr forwardingConf (toNetworkMagic networkId) Nothing $ Just (tracerSocket, Initiator) -- we need to provide NodeInfo DataPoint, to forward generator's name -- to the acceptor application (for example, 'cardano-tracer'). @@ -132,8 +133,10 @@ initTxGenTracers mbForwarding = do dpt :: Trace IO DataPoint dpt = dataPointTracer dpStore nodeInfoTracer <- mkDataPointTracer dpt - prepareGenInfo >>= traceWith nodeInfoTracer + !genInfo <- prepareGenInfo + traceWith nodeInfoTracer genInfo + kickoffForwarder pure $ forwardTracer forwardSink prepareGenInfo :: IO NodeInfo 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..461282d831d 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -106,9 +106,9 @@ library , attoparsec-aeson , base16-bytestring , bytestring - , cardano-api ^>= 10.1 + , cardano-api ^>= 10.6 , cardano-binary - , cardano-cli ^>= 10.1 + , cardano-cli ^>= 10.3 , cardano-crypto-class , cardano-crypto-wrapper , cardano-data @@ -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 817384d15f2..de569fdc0d1 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 2025-01-04T13:50:25Z + , hackage.haskell.org 2025-01-01T23:24:19Z + , cardano-haskell-packages 2025-01-16T11:44:54Z packages: cardano-node @@ -57,10 +57,6 @@ package bitvec package plutus-scripts-bench haddock-options: "--optghc=-fplugin-opt PlutusTx.Plugin:defer-errors" -constraints: - , wai-extra < 3.1.15 - , Cabal < 3.14 - allow-newer: , katip:Win32 , ekg-wai:time diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index 0d9a6c835f9..b5b350234ca 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.7 , network , process , random @@ -89,5 +89,5 @@ test-suite chairman-tests ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" build-tool-depends: cardano-node:cardano-node - , cardano-cli:cardano-cli ^>= 10.1 + , cardano-cli:cardano-cli ^>= 10.3 , cardano-node-chairman:cardano-node-chairman 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 de9617d7365..9874b9c8e3a 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -145,7 +145,7 @@ library , async , base16-bytestring , bytestring - , cardano-api ^>= 10.1 + , cardano-api ^>= 10.6 , cardano-crypto-class , cardano-crypto-wrapper , cardano-git-rev ^>=0.2.2 @@ -155,8 +155,7 @@ library , cardano-ledger-babbage , cardano-ledger-binary , cardano-ledger-byron - -- TODO: remove constraint at next ledger bump - , cardano-ledger-conway ^>= 1.17.4 + , cardano-ledger-conway , cardano-ledger-core , cardano-ledger-shelley , cardano-prelude @@ -169,35 +168,36 @@ 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 , network - , network-mux >= 0.4 + , network-mux >= 0.5 , nothunks , optparse-applicative-fork >= 0.18.1 - , ouroboros-consensus ^>= 0.21 - , ouroboros-consensus-cardano ^>= 0.20 - , ouroboros-consensus-diffusion ^>= 0.18 + , ouroboros-consensus ^>= 0.22 + , ouroboros-consensus-cardano ^>= 0.21 + , ouroboros-consensus-diffusion ^>= 0.19 , ouroboros-consensus-protocol - , ouroboros-network-api ^>= 0.10 - , ouroboros-network ^>= 0.17 + , ouroboros-network-api ^>= 0.12 + , ouroboros-network ^>= 0.19 , ouroboros-network-framework - , ouroboros-network-protocols ^>= 0.11 + , ouroboros-network-protocols ^>= 0.13 , prettyprinter , prettyprinter-ansi-terminal , psqueues + , resource-registry , safe-exceptions , scientific , si-timers @@ -209,11 +209,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..3b77283d991 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,13 @@ 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 (..), +import Ouroboros.Consensus.Node.Genesis (GenesisConfig, GenesisConfigFlags (..), + defaultGenesisConfigFlags, mkGenesisConfig) +import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag, NumOfDiskSnapshots (..), SnapshotInterval (..)) -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (..)) -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.Diffusion.Configuration as Configuration import Control.Monad (when) import Data.Aeson @@ -103,9 +106,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,19 +154,34 @@ 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 -- Enable Peer Sharing , ncPeerSharing :: PeerSharing + + -- Ouroboros Genesis + , ncGenesisConfig :: GenesisConfig } deriving (Eq, Show) @@ -185,9 +204,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,19 +233,32 @@ 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) -- Peer Sharing , pncPeerSharing :: !(Last PeerSharing) + + -- Ouroboros Genesis + , pncGenesisConfigFlags :: !(Last GenesisConfigFlags) } deriving (Eq, Generic, Show) instance AdjustFilePaths PartialNodeConfiguration where @@ -250,6 +283,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" @@ -268,7 +303,7 @@ instance FromJSON PartialNodeConfiguration where -- Logging parameters pncLoggingSwitch' <- v .:? "TurnOnLogging" .!= True pncLogMetrics <- Last <$> v .:? "TurnOnLogMetrics" - useTraceDispatcher <- v .:? "UseTraceDispatcher" .!= False + useTraceDispatcher <- v .:? "UseTraceDispatcher" .!= True pncTraceConfig <- if pncLoggingSwitch' then do partialTraceSelection <- parseJSON $ Object v @@ -301,13 +336,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 +365,10 @@ instance FromJSON PartialNodeConfiguration where -- Peer Sharing -- DISABLED BY DEFAULT - pncPeerSharing <- Last <$> v .:? "PeerSharing" .!= Just PeerSharingDisabled + pncPeerSharing <- Last <$> v .:? "PeerSharing" + + -- pncConsensusMode determines whether Genesis is enabled in the first place. + pncGenesisConfigFlags <- Last <$> v .:? "LowLevelGenesisOptions" pure PartialNodeConfiguration { pncProtocolConfig @@ -329,6 +376,7 @@ instance FromJSON PartialNodeConfiguration where , pncDiffusionMode , pncNumOfDiskSnapshots , pncSnapshotInterval + , pncDoDiskSnapshotChecksum , pncExperimentalProtocolsEnabled , pncMaxConcurrencyBulkSync , pncMaxConcurrencyDeadline @@ -348,15 +396,22 @@ 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 + , pncGenesisConfigFlags } where parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride @@ -500,6 +555,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 +579,38 @@ 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) + , pncGenesisConfigFlags = Last (Just defaultGenesisConfigFlags) } + 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 +629,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 @@ -598,6 +694,14 @@ makeNodeConfiguration pnc = do lastToEither "Missing PeerSharing" $ pncPeerSharing pnc + mGenesisConfigFlags <- case ncConsensusMode of + PraosMode -> pure Nothing + GenesisMode -> + fmap Just + $ lastToEither "Missing GenesisConfigFlags" + $ pncGenesisConfigFlags pnc + let ncGenesisConfig = mkGenesisConfig mGenesisConfigFlags + -- TODO: This is not mandatory experimentalProtocols <- lastToEither "Missing ExperimentalProtocolsEnabled" $ @@ -621,6 +725,7 @@ makeNodeConfiguration pnc = do , ncDiffusionMode = diffusionMode , ncNumOfDiskSnapshots = numOfDiskSnapshots , ncSnapshotInterval = snapshotInterval + , ncDoDiskSnapshotChecksum = doDiskSnapshotChecksum , ncExperimentalProtocolsEnabled = experimentalProtocols , ncMaxConcurrencyBulkSync = getLast $ pncMaxConcurrencyBulkSync pnc , ncMaxConcurrencyDeadline = getLast $ pncMaxConcurrencyDeadline pnc @@ -634,17 +739,24 @@ 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 + , ncGenesisConfig } 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..6d30abd0211 100644 --- a/cardano-node/src/Cardano/Node/Orphans.hs +++ b/cardano-node/src/Cardano/Node/Orphans.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} @@ -9,11 +11,13 @@ module Cardano.Node.Orphans () where import Cardano.Api () import Ouroboros.Consensus.Node -import qualified Data.Text as Text +import Ouroboros.Consensus.Node.Genesis (GenesisConfigFlags (..)) +import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag (..)) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) import Data.Aeson.Types +import qualified Data.Text as Text import Text.Printf (PrintfArg (..)) deriving instance Eq NodeDatabasePaths @@ -46,11 +50,26 @@ 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) + +instance FromJSON GenesisConfigFlags where + parseJSON = withObject "GenesisConfigFlags" $ \v -> + GenesisConfigFlags + <$> v .:? "EnableCSJ" .!= True + <*> v .:? "EnableLoEAndGDD" .!= True + <*> v .:? "EnableLoP" .!= True + <*> v .:? "BlockFetchGracePeriod" + <*> v .:? "BucketCapacity" + <*> v .:? "BucketRate" + <*> v .:? "CSJJumpSize" + <*> v .:? "GDDRateLimit" diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index d77bb991e28..2378ad91855 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,15 +118,22 @@ 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 + , pncGenesisConfigFlags = mempty } parseSocketPath :: Text -> Parser SocketPath diff --git a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs index caa24132d04..0fe737d4315 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs @@ -29,9 +29,9 @@ import Cardano.Node.Protocol.Types import Cardano.Node.Types import Cardano.Tracing.OrphanInstances.Byron () import Cardano.Tracing.OrphanInstances.Shelley () +import Data.Function ((&)) 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 +91,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 +165,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { shelleyGenesisHash, shelleyBasedLeaderCredentials = shelleyLeaderCredentials } - , Consensus.cardanoProtocolVersion = ProtVer (natVersion @10) 0 + , Consensus.cardanoProtocolVersion = ProtVer (natVersion @10) 2 -- The remaining arguments specify the parameters needed to transition between two eras , Consensus.cardanoLedgerTransitionConfig = Ledger.mkLatestTransitionConfig @@ -182,7 +176,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { Consensus.CardanoHardForkTriggers' { triggerHardForkShelley = -- What will trigger the Byron -> Shelley hard fork? - case npcTestShelleyHardForkAtEpoch of + npcTestShelleyHardForkAtEpoch & maybe -- This specifies the major protocol version number update that will -- trigger us moving to the Shelley protocol. @@ -202,37 +196,36 @@ 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) + Consensus.CardanoTriggerHardForkAtDefaultVersion -- Alternatively, for testing we can transition at a specific epoch. -- - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + Consensus.CardanoTriggerHardForkAtEpoch , triggerHardForkAllegra = - case npcTestAllegraHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 3 fromIntegral npcTestAllegraHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + npcTestAllegraHardForkAtEpoch & + maybe + Consensus.CardanoTriggerHardForkAtDefaultVersion + Consensus.CardanoTriggerHardForkAtEpoch , triggerHardForkMary = - case npcTestMaryHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 4 fromIntegral npcTestMaryHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + npcTestMaryHardForkAtEpoch & + maybe + Consensus.CardanoTriggerHardForkAtDefaultVersion + Consensus.CardanoTriggerHardForkAtEpoch , triggerHardForkAlonzo = - case npcTestAlonzoHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 5 fromIntegral npcTestAlonzoHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + npcTestAlonzoHardForkAtEpoch & + maybe + Consensus.CardanoTriggerHardForkAtDefaultVersion + Consensus.CardanoTriggerHardForkAtEpoch , triggerHardForkBabbage = - case npcTestBabbageHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 7 fromIntegral npcTestBabbageHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + npcTestBabbageHardForkAtEpoch & + maybe + Consensus.CardanoTriggerHardForkAtDefaultVersion + Consensus.CardanoTriggerHardForkAtEpoch , triggerHardForkConway = - case npcTestConwayHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 9 fromIntegral npcTestConwayHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + npcTestConwayHardForkAtEpoch & + maybe + Consensus.CardanoTriggerHardForkAtDefaultVersion + Consensus.CardanoTriggerHardForkAtEpoch } -- 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 c383befb163..e627b75934d 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 #-} @@ -8,7 +9,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -63,7 +63,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 +78,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 +91,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,18 +435,26 @@ 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 + { rnGenesisConfig = ncGenesisConfig nc , rnTraceConsensus = consensusTracers tracers , rnTraceNTN = nodeToNodeTracers tracers , rnTraceNTC = nodeToClientTracers tracers @@ -478,6 +486,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 +502,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do (readTVar publicRootsVar) (readTVar useLedgerVar) (readTVar useBootstrapVar) + (readTVar ledgerPeerSnapshotVar) in Node.run nodeArgs { @@ -496,6 +510,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 @@ -530,7 +545,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do (length ipProducerAddrs) nodeArgs = RunNodeArgs - { rnGenesisConfig = disableGenesisConfig + { rnGenesisConfig = ncGenesisConfig nc , rnTraceConsensus = consensusTracers tracers , rnTraceNTN = nodeToNodeTracers tracers , rnTraceNTC = nodeToClientTracers tracers @@ -650,6 +665,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do DiskPolicyArgs (ncSnapshotInterval nc) (ncNumOfDiskSnapshots nc) + (ncDoDiskSnapshotChecksum nc) -------------------------------------------------------------------------------- -- SIGHUP Handlers @@ -661,21 +677,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 +779,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 +796,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 +881,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 +977,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..0e820aef149 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 @@ -244,13 +247,12 @@ prepareNodeInfo nc (SomeConsensusProtocol whichP pForInfo) tc nodeStartTime = do Just aName -> return aName Nothing -> do -- The user didn't specify node's name in the configuration. - -- In this case we should form node's name as "host:port", where 'host' and 'port' - -- are taken from '--host-addr' and '--port' CLI-parameters correspondingly. - let SocketConfig hostIPv4 hostIPv6 port _ = ncSocketConfig nc - hostName <- case (show <$> hostIPv6) <> (show <$> hostIPv4) of - Last (Just addr) -> return addr - Last Nothing -> getHostName - return . pack $ hostName <> maybe "" ((":" ++) . show) (getLast port) + -- In this case we should form node's name as "host_port", + -- where 'host' is the machine's host name and 'port' is taken + -- from the '--port' CLI-parameter. + let SocketConfig{ncNodePortNumber = port} = ncSocketConfig nc + hostName <- getHostName + return . pack $ hostName <> "_" <> show (getLast port) -- | This information is taken from 'BasicInfoShelleyBased'. It is required for -- 'cardano-tracer' service (particularly, for RTView). diff --git a/cardano-node/src/Cardano/Node/Tracing/API.hs b/cardano-node/src/Cardano/Node/Tracing/API.hs index cf8f182411b..34f6f853e9a 100644 --- a/cardano-node/src/Cardano/Node/Tracing/API.hs +++ b/cardano-node/src/Cardano/Node/Tracing/API.hs @@ -33,6 +33,7 @@ import Ouroboros.Network.NodeToNode (RemoteAddress) import Prelude +import Control.DeepSeq (deepseq) import "contra-tracer" Control.Tracer (traceWith) import "trace-dispatcher" Control.Tracer (nullTracer) import Data.Bifunctor (first) @@ -61,7 +62,15 @@ initTraceDispatcher nc p networkMagic nodeKernel p2pMode = do (unConfigPath $ ncConfigFile nc) defaultCardanoConfig - tracers <- mkTracers trConfig + (kickoffForwarder, tracers) <- mkTracers trConfig + + -- The NodeInfo DataPoint needs to be fully evaluated and stored + -- before it is queried for the first time by cardano-tracer. + -- Hence, we delay initiating the forwarding connection. + nodeInfo <- prepareNodeInfo nc p trConfig =<< getCurrentTime + nodeInfo `deepseq` traceWith (nodeInfoTracer tracers) nodeInfo + + kickoffForwarder traceWith (nodeStateTracer tracers) NodeTracingOnlineConfiguring @@ -74,8 +83,6 @@ initTraceDispatcher nc p networkMagic nodeKernel p2pMode = do nodeKernel (fromMaybe 2000 (tcPeerFrequency trConfig)) - now <- getCurrentTime - prepareNodeInfo nc p trConfig now >>= traceWith (nodeInfoTracer tracers) pure tracers where @@ -88,21 +95,21 @@ initTraceDispatcher nc p networkMagic nodeKernel p2pMode = do -- We should initialize forwarding only if 'Forwarder' backend -- is presented in the node's configuration. - (fwdTracer, dpTracer) <- + (fwdTracer, dpTracer, kickoffForwarder) <- if forwarderBackendEnabled then do -- TODO: check if this is the correct way to use withIOManager - (forwardSink, dpStore) <- withIOManager $ \iomgr -> do + (forwardSink, dpStore, kickoffForwarder) <- withIOManager $ \iomgr -> do let tracerSocketMode = Just . first unFile =<< ncTraceForwardSocket nc forwardingConf = fromMaybe defaultForwarder (tcForwarder trConfig) - initForwarding iomgr forwardingConf networkMagic (Just ekgStore) tracerSocketMode - pure (forwardTracer forwardSink, dataPointTracer dpStore) + initForwardingDelayed iomgr forwardingConf networkMagic (Just ekgStore) tracerSocketMode + pure (forwardTracer forwardSink, dataPointTracer dpStore, kickoffForwarder) else -- Since 'Forwarder' backend isn't enabled, there is no forwarding. -- So we use nullTracers to ignore 'TraceObject's and 'DataPoint's. - pure (Trace nullTracer, Trace nullTracer) + pure (Trace nullTracer, Trace nullTracer, pure ()) - mkDispatchTracers + (,) kickoffForwarder <$> mkDispatchTracers nodeKernel stdoutTrace fwdTracer @@ -111,6 +118,7 @@ initTraceDispatcher nc p networkMagic nodeKernel p2pMode = do trConfig p2pMode p + where forwarderBackendEnabled = (any (any checkForwarder) . Map.elems) $ tcOptions trConfig 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/DefaultTraceConfig.hs b/cardano-node/src/Cardano/Node/Tracing/DefaultTraceConfig.hs index e2f748e1604..95fb8f52ca3 100644 --- a/cardano-node/src/Cardano/Node/Tracing/DefaultTraceConfig.hs +++ b/cardano-node/src/Cardano/Node/Tracing/DefaultTraceConfig.hs @@ -11,62 +11,63 @@ import qualified Data.Map.Strict as Map defaultCardanoConfig :: TraceConfig defaultCardanoConfig = emptyTraceConfig { - tcOptions = Map.fromList - [([], - [ ConfSeverity (SeverityF (Just Notice)) -- Means Silence - , ConfDetail DNormal - , ConfBackend [Stdout MachineFormat - , EKGBackend - , Forwarder - ]]) + tcMetricsPrefix = Just "cardano.node.metrics." + , tcOptions = Map.fromList + [([], + [ ConfSeverity (SeverityF (Just Notice)) -- Means Silence + , ConfDetail DNormal + , ConfBackend [Stdout MachineFormat + , EKGBackend + , Forwarder + ]]) --- more important tracers going here - ,(["BlockFetch", "Decision"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["ChainDB"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["ChainSync", "Client"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Net", "ConnectionManager", "Remote"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Net", "Subscription", "DNS"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Startup", "DiffusionInit"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Net", "ErrorPolicy"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Forge", "Loop"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Forge", "StateInfo"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Net", "InboundGovernor", "Remote"], - [ ConfSeverity (SeverityF (Just Info))]) - -- includes ["Net", "InboundGovernor", "Remote", "Transition"] - ,(["Net", "Subscription", "IP"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Net", "ErrorPolicy", "Local"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Mempool"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Net", "Mux", "Remote"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Net", "PeerSelection"], - [ ConfSeverity (SeverityF (Just Info))]) - ,(["Resources"], - [ ConfSeverity (SeverityF (Just Info))]) - --- Limiters - ,(["ChainDB","AddBlockEvent","AddedBlockToQueue"], - [ ConfLimiter 2.0]) - ,(["ChainDB","AddBlockEvent","AddedBlockToVolatileDB"], - [ ConfLimiter 2.0]) - ,(["ChainDB","AddBlockEvent","AddBlockValidation", "ValidCandidate"], - [ ConfLimiter 2.0]) - ,(["ChainDB", "CopyToImmutableDBEvent", "CopiedBlockToImmutableDB"], - [ ConfLimiter 2.0]) - ,(["ChainSync","Client","DownloadedHeader"], - [ ConfLimiter 2.0]) - ,(["BlockFetch", "Client", "CompletedBlockFetch"], - [ ConfLimiter 2.0]) - ] + -- more important tracers going here + ,(["BlockFetch", "Decision"], + [ ConfSeverity (SeverityF Nothing)]) + ,(["ChainDB"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["ChainDB", "AddBlockEvent", "AddBlockValidation"], + [ ConfSeverity (SeverityF Nothing)]) + ,(["ChainSync", "Client"], + [ ConfSeverity (SeverityF (Just Warning))]) + ,(["Net", "ConnectionManager", "Remote"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Net", "Subscription", "DNS"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Startup", "DiffusionInit"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Net", "ErrorPolicy"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Forge", "Loop"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Forge", "StateInfo"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Net", "InboundGovernor", "Remote"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Net", "Subscription", "IP"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Net", "ErrorPolicy", "Local"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Mempool"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Net", "Mux", "Remote"], + [ ConfSeverity (SeverityF (Just Info))]) + ,(["Net", "InboundGovernor"], + [ ConfSeverity (SeverityF (Just Warning))]) + ,(["Net", "PeerSelection"], + [ ConfSeverity (SeverityF Nothing)]) + ,(["Resources"], + [ ConfSeverity (SeverityF Nothing)]) + -- Limiters + ,(["ChainDB","AddBlockEvent","AddedBlockToQueue"], + [ ConfLimiter 2.0]) + ,(["ChainDB","AddBlockEvent","AddedBlockToVolatileDB"], + [ ConfLimiter 2.0]) + ,(["ChainDB","AddBlockEvent","AddBlockValidation", "ValidCandidate"], + [ ConfLimiter 2.0]) + ,(["ChainDB", "CopyToImmutableDBEvent", "CopiedBlockToImmutableDB"], + [ ConfLimiter 2.0]) + ,(["BlockFetch", "Client", "CompletedBlockFetch"], + [ ConfLimiter 2.0]) + ] } 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 696c710fdcc..fe32e91f5a3 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -96,9 +96,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) = @@ -122,23 +133,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) = @@ -163,6 +177,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 = @@ -210,6 +225,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 = @@ -257,6 +273,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 = @@ -332,6 +349,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)) = @@ -358,7 +379,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where allNamespaces = Namespace [] ["LastShutdownUnclean"] - + : Namespace [] ["ChainSelStarvationEvent"] : (map (nsPrependInner "AddBlockEvent") (allNamespaces :: [Namespace (ChainDB.TraceAddBlockEvent blk)]) ++ map (nsPrependInner "FollowerEvent") @@ -417,8 +438,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) = @@ -438,8 +457,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." @@ -468,10 +485,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 ] @@ -562,9 +575,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 = @@ -640,8 +650,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 {} = @@ -658,8 +666,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 = @@ -673,7 +679,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 @@ -693,7 +698,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 = @@ -793,10 +797,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 "" @@ -829,11 +829,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 @@ -844,7 +839,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where , Namespace [] ["IgnoreBlockAlreadyInVolatileDB"] , Namespace [] ["IgnoreInvalidBlock"] , Namespace [] ["AddedBlockToQueue"] - , Namespace [] ["BlockInTheFuture"] , Namespace [] ["AddedBlockToVolatileDB"] , Namespace [] ["PoppedBlockFromQueue"] , Namespace [] ["TryAddToCurrentChain"] @@ -853,7 +847,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where , Namespace [] ["ChangingSelection"] , Namespace [] ["AddedToCurrentChain"] , Namespace [] ["SwitchedToAFork"] - , Namespace [] ["ChainSelectionForFutureBlock"] , Namespace [] ["AddedReprocessLoEBlocksToQueue"] , Namespace [] ["PoppedReprocessLoEBlocksFromQueue"] , Namespace [] ["ChainSelectionLoEDebug"] @@ -1171,14 +1164,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) @@ -1200,14 +1185,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) @@ -1222,18 +1199,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 @@ -1242,16 +1213,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." @@ -1261,8 +1222,6 @@ instance MetaTrace (ChainDB.TraceValidationEvent blk) where allNamespaces = [ Namespace [] ["ValidCandidate"] - , Namespace [] ["CandidateContainsFutureBlocks"] - , Namespace [] ["CandidateContainsFutureBlocksExceedingClockSkew"] , Namespace [] ["InvalidBlock"] , Namespace [] ["UpdateLedgerDb"] ] @@ -1584,21 +1543,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" @@ -1612,15 +1585,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 @@ -1632,12 +1611,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"] ] @@ -2338,23 +2320,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..7fd49d4a615 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,6 +66,7 @@ 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 (..)) @@ -84,6 +86,7 @@ import qualified Data.List as List import qualified Data.Text as Text import Data.Time (DiffTime, NominalDiffTime) import Data.Word (Word32, Word64) +import Network.TypedProtocol.Core instance (LogFormatting adr, Show adr) => LogFormatting (ConnectionId adr) where @@ -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 @@ -367,6 +377,8 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where Namespace [] ["JumpingWaitingForNextInstruction"] TraceJumpingInstructionIs _ -> Namespace [] ["JumpingInstructionIs"] + TraceDrainingThePipe _ -> + Namespace [] ["DrainingThePipe"] severityFor ns _ = case ns of @@ -396,6 +408,8 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where Just Debug Namespace _ ["JumpingInstructionIs"] -> Just Debug + Namespace _ ["DrainingThePipe"] -> + Just Debug _ -> Nothing @@ -433,6 +447,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 +466,7 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where , Namespace [] ["JumpResult"] , Namespace [] ["JumpingWaitingForNextInstruction"] , Namespace [] ["JumpingInstructionIs"] + , Namespace [] ["DrainingThePipe"] ] -------------------------------------------------------------------------------- @@ -659,6 +676,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 +1423,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 +1520,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) = @@ -2189,6 +2238,44 @@ instance MetaTrace (TraceGsmEvent selection) where , Namespace [] ["GsmEventSyncingToPreSyncing"] ] +-------------------------------------------------------------------------------- +-- CSJ Tracer +-------------------------------------------------------------------------------- + +instance ( LogFormatting peer, Show peer + ) => LogFormatting (Jumping.TraceEvent peer) where + forMachine dtal = + \case + RotatedDynamo oldPeer newPeer -> + mconcat + [ "kind" .= String "RotatedDynamo" + , "oldPeer" .= forMachine dtal oldPeer + , "newPeer" .= forMachine dtal newPeer + ] + + forHuman (RotatedDynamo fromPeer toPeer) = + "Rotated the dynamo from " <> showT fromPeer <> " to " <> showT toPeer + +instance MetaTrace (Jumping.TraceEvent peer) where + namespaceFor = + \case + RotatedDynamo {} -> Namespace [] ["RotatedDynamo"] + + severityFor ns _ = + case ns of + Namespace _ ["RotatedDynamo"] -> Just Info + Namespace _ _ -> Nothing + + documentFor = \case + Namespace _ ["RotatedDynamo"] -> + Just "The ChainSync Jumping module has been asked to rotate its dynamo" + Namespace _ _ -> + Nothing + + allNamespaces = + [ Namespace [] ["RotatedDynamo"] + ] + -------------------------------------------------------------------------------- -- Chain tip tracer -------------------------------------------------------------------------------- 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..67a5d2c51ab 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"] ] -------------------------------------------------------------------------------- @@ -1000,7 +1011,7 @@ instance LogFormatting PeerSelectionCounters where instance MetaTrace PeerSelectionCounters where namespaceFor PeerSelectionCounters {} = Namespace [] ["Counters"] - severityFor (Namespace _ ["Counters"]) _ = Just Info + severityFor (Namespace _ ["Counters"]) _ = Just Debug severityFor _ _ = Nothing documentFor (Namespace _ ["Counters"]) = Just @@ -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"] @@ -1407,7 +1437,7 @@ instance MetaTrace (ConnectionManagerTrace addr severityFor (Namespace _ ["ConnectionCleanup"]) _ = Just Debug severityFor (Namespace _ ["ConnectionTimeWait"]) _ = Just Debug severityFor (Namespace _ ["ConnectionTimeWaitDone"]) _ = Just Info - severityFor (Namespace _ ["ConnectionManagerCounters"]) _ = Just Info + severityFor (Namespace _ ["ConnectionManagerCounters"]) _ = Just Debug severityFor (Namespace _ ["State"]) _ = Just Info severityFor (Namespace _ ["UnexpectedlyFalseAssertion"]) _ = Just Error severityFor _ _ = Nothing @@ -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..219ff94cf73 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs @@ -26,13 +26,13 @@ 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, - renderPointForVerbosity, renderRealPoint, renderRealPointAsPhrase, - renderTipBlockNo, renderTipHash, renderWithOrigin) + 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, - pointHash, realPointHash, realPointSlot, withOriginToMaybe) + Header, RealPoint, blockNo, blockPoint, blockPrevHash, getHeader, pointHash, + realPointHash, realPointSlot, withOriginToMaybe) import Ouroboros.Consensus.Block.SupportsSanityCheck import Ouroboros.Consensus.Genesis.Governor (DensityBounds (..), GDDDebugInfo (..), TraceGDDEvent (..)) @@ -91,6 +91,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word (Word32) import GHC.Generics (Generic) +import Network.TypedProtocol.Core import Numeric (showFFloat) @@ -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,20 @@ 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)) ] +instance HasPrivacyAnnotation (ChainSync.Client.TraceEvent peer) where +instance HasSeverityAnnotation (ChainSync.Client.TraceEvent peer) where + getSeverityAnnotation _ = Debug +instance ToObject peer => Transformable Text IO (ChainSync.Client.TraceEvent peer) where + trTransformer = trStructured + +instance ToObject peer => ToObject (ChainSync.Client.TraceEvent peer) where + toObject verb (ChainSync.Client.RotatedDynamo oldPeer newPeer) = + mconcat + [ "kind" .= String "RotatedDynamo" + , "oldPeer" .= toObject verb oldPeer + , "newPeer" .= toObject verb newPeer + ] + 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..c36aa985814 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 (..), @@ -78,7 +85,7 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers 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 (..)) + LocalRootPeers, WarmValency (..), 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 +93,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 +104,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 +129,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 +183,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 +217,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 +262,7 @@ instance HasSeverityAnnotation TraceLedgerPeers where TraceLedgerPeersDomains {} -> Debug TraceLedgerPeersResult {} -> Debug TraceLedgerPeersFailure {} -> Debug + UsingBigLedgerPeerSnapshot {} -> Debug instance HasPrivacyAnnotation (WithAddr addr ErrorPolicyTrace) @@ -369,38 +389,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 +465,7 @@ instance HasSeverityAnnotation (TracePeerSelection addr) where TraceGovernorWakeup {} -> Info TraceChurnWait {} -> Info TraceChurnMode {} -> Info + -- TraceVerifyPeerSnapshot {} -> Info TraceForgetBigLedgerPeers {} -> Info @@ -484,6 +505,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 +520,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 +564,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 +575,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 +632,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 +646,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 +660,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 +688,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 +760,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 +804,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 +822,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 +851,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 +892,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 +926,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 +1007,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 +1025,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 +1060,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 +1094,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 +1131,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 +1203,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 +1236,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 +1350,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 +1405,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 +1593,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 +1628,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 +1647,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 +2084,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 +2228,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 +2277,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 +2343,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 +2405,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 +2429,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 +2515,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 +2540,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 +2587,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 +2670,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..106bbc7d241 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 @@ -14,12 +15,11 @@ import Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartia partialTraceSelectionToEither) import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) +import Ouroboros.Consensus.Node.Genesis (disableGenesisConfig) 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 +119,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 +137,22 @@ 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 + , pncGenesisConfigFlags = mempty } -- | Example partial configuration theoretically created @@ -161,6 +169,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 +185,22 @@ 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) + , pncGenesisConfigFlags = mempty } -- | Expected final NodeConfiguration @@ -205,6 +221,7 @@ eExpectedConfig = do , ncDiffusionMode = InitiatorAndResponderDiffusionMode , ncNumOfDiskSnapshots = DefaultNumOfDiskSnapshots , ncSnapshotInterval = RequestedSnapshotInterval $ secondsToDiffTime 100 + , ncDoDiskSnapshotChecksum = DoDiskSnapshotChecksum , ncExperimentalProtocolsEnabled = True , ncMaxConcurrencyBulkSync = Nothing , ncMaxConcurrencyDeadline = Nothing @@ -222,15 +239,22 @@ 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 + , ncGenesisConfig = disableGenesisConfig } -- ----------------------------------------------------------------------------- diff --git a/cardano-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index c5032f24142..0126b62bcf6 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -39,9 +39,9 @@ library , aeson , async , bytestring - , cardano-api ^>= 10.1 + , cardano-api ^>= 10.6 , cardano-binary - , cardano-cli ^>= 10.1 + , cardano-cli ^>= 10.3 , cardano-crypto-class ^>= 2.1.2 , http-media , iohk-monitoring @@ -49,7 +49,7 @@ library , network , optparse-applicative-fork , ouroboros-consensus-cardano - , ouroboros-network ^>= 0.17 + , ouroboros-network ^>= 0.19 , ouroboros-network-protocols , prometheus >= 2.2.4 , servant diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index 65dc8812e7e..6a4eb37efb4 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -35,8 +35,8 @@ library , aeson-pretty , ansi-terminal , bytestring - , cardano-api ^>= 10.1 - , cardano-cli ^>= 10.1 + , cardano-api ^>= 10.6 + , cardano-cli:{cardano-cli, cardano-cli-test-lib} ^>= 10.3 , cardano-crypto-class , cardano-crypto-wrapper , cardano-git-rev ^>= 0.2.2 @@ -49,7 +49,7 @@ library , cardano-ledger-core:{cardano-ledger-core, testlib} , cardano-ledger-shelley , cardano-node - , cardano-ping ^>= 0.5 + , cardano-ping ^>= 0.7 , contra-tracer , containers , data-default-class @@ -62,15 +62,16 @@ library , exceptions , filepath , hedgehog - , hedgehog-extras ^>= 0.6.4 + , hedgehog-extras ^>= 0.7 , lens-aeson , microlens + , monad-control , mono-traversable , mtl , network , network-mux , optparse-applicative-fork - , ouroboros-network ^>= 0.17 + , ouroboros-network ^>= 0.19 , ouroboros-network-api , prettyprinter , process @@ -204,6 +205,7 @@ test-suite cardano-testnet-test Cardano.Testnet.Test.Gov.PredefinedAbstainDRep Cardano.Testnet.Test.Gov.ProposeNewConstitution Cardano.Testnet.Test.Gov.ProposeNewConstitutionSPO + Cardano.Testnet.Test.Gov.Transaction.HashMismatch Cardano.Testnet.Test.Gov.TreasuryDonation Cardano.Testnet.Test.Gov.TreasuryGrowth Cardano.Testnet.Test.Gov.TreasuryWithdrawal @@ -220,7 +222,7 @@ test-suite cardano-testnet-test , base16-bytestring , bytestring , cardano-api:{cardano-api, internal} - , cardano-cli + , cardano-cli:{cardano-cli, cardano-cli-test-lib} , cardano-crypto-class , cardano-ledger-conway , cardano-ledger-core @@ -240,6 +242,7 @@ test-suite cardano-testnet-test , lens , lens-aeson , microlens + , monad-control , mtl , process , regex-compat 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..bae90ad5282 100644 --- a/cardano-testnet/src/Testnet/Defaults.hs +++ b/cardano-testnet/src/Testnet/Defaults.hs @@ -76,6 +76,7 @@ import qualified Data.Text as Text import Data.Time (UTCTime) import qualified Data.Vector as Vector import Data.Word (Word64) +import GHC.Exts (IsList (..)) import Lens.Micro import Numeric.Natural import System.FilePath (()) @@ -161,6 +162,7 @@ defaultYamlHardforkViaConfig :: ShelleyBasedEra era -> Aeson.KeyMap Aeson.Value defaultYamlHardforkViaConfig sbe = defaultYamlConfig <> tracers + <> fromList [("TraceOptions", Aeson.Object mempty)] <> protocolVersions sbe <> hardforkViaConfig sbe where @@ -290,7 +292,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 +547,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..5f3b5e3f4e7 100644 --- a/cardano-testnet/src/Testnet/Process/Cli/DRep.hs +++ b/cardano-testnet/src/Testnet/Process/Cli/DRep.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -26,6 +27,7 @@ import Prelude import Control.Monad (forM, void) import Control.Monad.Catch (MonadCatch) +import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Lens as AL import Data.Text (Text) @@ -35,11 +37,13 @@ import Data.Word (Word16) import GHC.Exts (fromString) import GHC.Stack import Lens.Micro ((^?)) +import System.Directory (makeAbsolute) import System.FilePath (()) +import Test.Cardano.CLI.Hash (serveFilesWhile) import Testnet.Components.Query import Testnet.Process.Cli.Transaction -import Testnet.Process.Run (execCli', execCliStdoutToJson) +import Testnet.Process.Run (addEnvVarsToConfig, execCli', execCliStdoutToJson) import Testnet.Types import Hedgehog (MonadTest, evalMaybe) @@ -227,7 +231,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 @@ -339,7 +343,7 @@ getLastPParamUpdateActionId execConfig = do -- | Create a proposal to change the DRep activity interval. -- Return the transaction id and the index of the governance action. makeActivityChangeProposal - :: (HasCallStack, H.MonadAssertion m, MonadTest m, MonadCatch m, MonadIO m, Typeable era) + :: (HasCallStack, MonadBaseControl IO m, H.MonadAssertion m, MonadTest m, MonadCatch m, MonadIO m, Typeable era) => H.ExecConfig -- ^ Specifies the CLI execution configuration. -> EpochStateView -- ^ Current epoch state view for transaction building. It can be obtained -- using the 'getEpochStateView' function. @@ -354,51 +358,59 @@ 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 baseDir <- H.createDirectoryIfMissing work - proposalAnchorFile <- H.note $ baseDir "sample-proposal-anchor" - H.writeFile proposalAnchorFile $ - unlines [ "These are the reasons: " , "" , "1. First" , "2. Second " , "3. Third" ] - + let proposalAnchorDataIpfsHash = "QmexFJuEn5RtnHEqpxDcqrazdHPzAwe7zs2RxHLfMH5gBz" + proposalAnchorFile <- H.noteM $ liftIO $ makeAbsolute $ "test" "cardano-testnet-test" "files" "sample-proposal-anchor" proposalAnchorDataHash <- execCli' execConfig - [ "hash", "anchor-data", "--file-text", proposalAnchorFile + [ "hash", "anchor-data", "--file-binary", proposalAnchorFile ] - minDRepDeposit <- getMinDRepDeposit epochStateView ceo + proposalFile <- H.note $ baseDir "proposa-file" - proposalFile <- H.note $ baseDir "sample-proposal-anchor" + minDRepDeposit <- getMinDRepDeposit epochStateView ceo - void $ execCli' execConfig $ - [ "conway", "governance", "action", "create-protocol-parameters-update" - , "--testnet" - , "--governance-action-deposit", show @Integer minDRepDeposit - , "--deposit-return-stake-verification-key-file", stakeVkeyFp - ] ++ concatMap (\(prevGovernanceActionTxId, prevGovernanceActionIndex) -> - [ "--prev-governance-action-tx-id", prevGovernanceActionTxId - , "--prev-governance-action-index", show prevGovernanceActionIndex - ]) prevGovActionInfo ++ - [ "--drep-activity", show (unEpochInterval drepActivity) - , "--anchor-url", "https://tinyurl.com/3wrwb2as" - , "--anchor-data-hash", proposalAnchorDataHash - , "--out-file", proposalFile - ] + let relativeUrl = ["ipfs", proposalAnchorDataIpfsHash] proposalBody <- H.note $ baseDir "tx.body" txIn <- findLargestUtxoForPaymentKey epochStateView sbe wallet - void $ execCli' execConfig - [ "conway", "transaction", "build" - , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet - , "--tx-in", Text.unpack $ renderTxIn txIn - , "--proposal-file", proposalFile - , "--out-file", proposalBody - ] + -- Create temporary HTTP server with files required by the call to `cardano-cli` + -- In this case, the server emulates an IPFS gateway + serveFilesWhile + [(relativeUrl, proposalAnchorFile)] + ( \port -> do + let execConfig' = addEnvVarsToConfig execConfig [("IPFS_GATEWAY_URI", "http://localhost:" ++ show port ++ "/")] + void $ execCli' execConfig' $ + [ "conway", "governance", "action", "create-protocol-parameters-update" + , "--testnet" + , "--governance-action-deposit", show @Integer minDRepDeposit + , "--deposit-return-stake-verification-key-file", stakeVkeyFp + ] ++ concatMap (\(prevGovernanceActionTxId, prevGovernanceActionIndex) -> + [ "--prev-governance-action-tx-id", prevGovernanceActionTxId + , "--prev-governance-action-index", show prevGovernanceActionIndex + ]) prevGovActionInfo ++ + [ "--drep-activity", show (unEpochInterval drepActivity) + , "--anchor-url", "ipfs://" ++ proposalAnchorDataIpfsHash + , "--anchor-data-hash", proposalAnchorDataHash + , "--check-anchor-data" + , "--out-file", proposalFile + ] + + void $ execCli' execConfig' + [ "conway", "transaction", "build" + , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet + , "--tx-in", Text.unpack $ renderTxIn txIn + , "--proposal-file", proposalFile + , "--out-file", proposalBody + ] + ) signedProposalTx <- signTx execConfig cEra baseDir "signed-proposal" (File proposalBody) [Some $ paymentKeyInfoPair wallet] diff --git a/cardano-testnet/src/Testnet/Process/Run.hs b/cardano-testnet/src/Testnet/Process/Run.hs index 8c0be2f8612..87f160873f8 100644 --- a/cardano-testnet/src/Testnet/Process/Run.hs +++ b/cardano-testnet/src/Testnet/Process/Run.hs @@ -18,6 +18,7 @@ module Testnet.Process.Run , mkExecConfigOffline , ProcessError(..) , ExecutableError(..) + , addEnvVarsToConfig ) where import Prelude @@ -33,6 +34,7 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as LBS import Data.Function import qualified Data.List as List +import Data.Maybe (fromMaybe) import Data.Monoid (Last (..)) import Data.String (fromString) import qualified Data.Text as Text @@ -193,6 +195,16 @@ mkExecConfig tempBaseAbsPath sprocket networkId = do , H.execConfigCwd = Last $ Just tempBaseAbsPath } +-- | Adds environment variables to an 'ExecConfig' that may already +-- have some environment variables set. This is done by prepending the new +-- environment variables to the existing ones. +addEnvVarsToConfig :: H.ExecConfig -> [(String, String)] -> H.ExecConfig +addEnvVarsToConfig execConfig newEnvVars = + execConfig { H.execConfigEnv = Last $ Just $ newEnvVars <> prevEnvVars } + where + prevEnvVars :: [(String, String)] + prevEnvVars = fromMaybe [] . getLast $ H.execConfigEnv execConfig + -- | Creates an 'ExecConfig' that can be used to run a process offline. -- e.g cardano-cli without a node running. mkExecConfigOffline :: () diff --git a/cardano-testnet/src/Testnet/Property/Assert.hs b/cardano-testnet/src/Testnet/Property/Assert.hs index 6b83481aef1..7b52c65e0ae 100644 --- a/cardano-testnet/src/Testnet/Property/Assert.hs +++ b/cardano-testnet/src/Testnet/Property/Assert.hs @@ -117,7 +117,7 @@ assertChainExtended deadline nodeLoggingFormat nodeStdoutFile = withFrozenCallSt case nodeLoggingFormat of NodeLoggingFormatAsText -> IO.fileContains "Chain extended, new tip" nodeStdoutFile NodeLoggingFormatAsJson -> fileJsonGrep nodeStdoutFile $ \v -> - Aeson.parseMaybe (Aeson.parseJSON @(LogEntry Kind)) v == Just (LogEntry (Kind "TraceAddBlockEvent.AddedToCurrentChain")) + Aeson.parseMaybe (Aeson.parseJSON @(LogEntry Kind)) v == Just (LogEntry (Kind "AddedToCurrentChain")) newtype LogEntry a = LogEntry { unLogEntry :: a 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-golden/files/golden/allegra_node_default_config.json b/cardano-testnet/test/cardano-testnet-golden/files/golden/allegra_node_default_config.json index 44f32c29f37..e35f4f2b149 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/allegra_node_default_config.json +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/allegra_node_default_config.json @@ -1,6 +1,6 @@ { "AlonzoGenesisFile": "alonzo-genesis.json", - "ByronGenesisFile": "byron/genesis.json", + "ByronGenesisFile": "byron-genesis.json", "ConwayGenesisFile": "conway-genesis.json", "EnableLogMetrics": false, "EnableLogging": true, @@ -47,6 +47,7 @@ "TraceLocalTxSubmissionServer": false, "TraceMempool": true, "TraceMux": false, + "TraceOptions": {}, "TracePeerSelection": true, "TracePeerSelectionActions": true, "TracePublicRootPeers": true, diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/alonzo_node_default_config.json b/cardano-testnet/test/cardano-testnet-golden/files/golden/alonzo_node_default_config.json index 3ce2f6076d3..340be9c7af2 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/alonzo_node_default_config.json +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/alonzo_node_default_config.json @@ -1,6 +1,6 @@ { "AlonzoGenesisFile": "alonzo-genesis.json", - "ByronGenesisFile": "byron/genesis.json", + "ByronGenesisFile": "byron-genesis.json", "ConwayGenesisFile": "conway-genesis.json", "EnableLogMetrics": false, "EnableLogging": true, @@ -49,6 +49,7 @@ "TraceLocalTxSubmissionServer": false, "TraceMempool": true, "TraceMux": false, + "TraceOptions": {}, "TracePeerSelection": true, "TracePeerSelectionActions": true, "TracePublicRootPeers": true, diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/babbage_node_default_config.json b/cardano-testnet/test/cardano-testnet-golden/files/golden/babbage_node_default_config.json index d7ea49aeff9..8525dc82b9d 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/babbage_node_default_config.json +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/babbage_node_default_config.json @@ -1,6 +1,6 @@ { "AlonzoGenesisFile": "alonzo-genesis.json", - "ByronGenesisFile": "byron/genesis.json", + "ByronGenesisFile": "byron-genesis.json", "ConwayGenesisFile": "conway-genesis.json", "EnableLogMetrics": false, "EnableLogging": true, @@ -50,6 +50,7 @@ "TraceLocalTxSubmissionServer": false, "TraceMempool": true, "TraceMux": false, + "TraceOptions": {}, "TracePeerSelection": true, "TracePeerSelectionActions": true, "TracePublicRootPeers": true, diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/conway_node_default_config.json b/cardano-testnet/test/cardano-testnet-golden/files/golden/conway_node_default_config.json index 72ced6105f5..6da59b1b9e5 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/conway_node_default_config.json +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/conway_node_default_config.json @@ -1,6 +1,6 @@ { "AlonzoGenesisFile": "alonzo-genesis.json", - "ByronGenesisFile": "byron/genesis.json", + "ByronGenesisFile": "byron-genesis.json", "ConwayGenesisFile": "conway-genesis.json", "EnableLogMetrics": false, "EnableLogging": true, @@ -51,6 +51,7 @@ "TraceLocalTxSubmissionServer": false, "TraceMempool": true, "TraceMux": false, + "TraceOptions": {}, "TracePeerSelection": true, "TracePeerSelectionActions": true, "TracePublicRootPeers": true, diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/mary_node_default_config.json b/cardano-testnet/test/cardano-testnet-golden/files/golden/mary_node_default_config.json index 9327a0bab20..8cf9248d98b 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/mary_node_default_config.json +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/mary_node_default_config.json @@ -1,6 +1,6 @@ { "AlonzoGenesisFile": "alonzo-genesis.json", - "ByronGenesisFile": "byron/genesis.json", + "ByronGenesisFile": "byron-genesis.json", "ConwayGenesisFile": "conway-genesis.json", "EnableLogMetrics": false, "EnableLogging": true, @@ -48,6 +48,7 @@ "TraceLocalTxSubmissionServer": false, "TraceMempool": true, "TraceMux": false, + "TraceOptions": {}, "TracePeerSelection": true, "TracePeerSelectionActions": true, "TracePublicRootPeers": true, diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/shelley_node_default_config.json b/cardano-testnet/test/cardano-testnet-golden/files/golden/shelley_node_default_config.json index c547576caf0..50494b46a98 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/shelley_node_default_config.json +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/shelley_node_default_config.json @@ -1,6 +1,6 @@ { "AlonzoGenesisFile": "alonzo-genesis.json", - "ByronGenesisFile": "byron/genesis.json", + "ByronGenesisFile": "byron-genesis.json", "ConwayGenesisFile": "conway-genesis.json", "EnableLogMetrics": false, "EnableLogging": true, @@ -46,6 +46,7 @@ "TraceLocalTxSubmissionServer": false, "TraceMempool": true, "TraceMux": false, + "TraceOptions": {}, "TracePeerSelection": true, "TracePeerSelectionActions": true, "TracePublicRootPeers": true, 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..aa316ce559c 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,14 @@ hprop_cli_queries = integrationWorkspace "cli-queries" $ \tempAbsBasePath' -> H. -- treasury H.noteM_ $ execCli' execConfig [ eraName, "query", "treasury" ] + TestQueryProposalsCmd -> do + -- TODO @cardano-cli team + pure () + + TestQueryLedgerPeerSnapshotCmd -> 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..d864f61db17 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 @@ -40,7 +40,7 @@ import qualified Hedgehog.Extras as H -- | Execute me with: -- @DISABLE_RETRIES=1 cabal test cardano-testnet-test --test-options '-p "/register deregister stake address in transaction build/"'@ hprop_tx_register_deregister_stake_address :: Property -hprop_tx_register_deregister_stake_address = integrationWorkspace "register-deregister-stake-address" $ \tempAbsBasePath' -> H.runWithDefaultWatchdog_ $ do +hprop_tx_register_deregister_stake_address = integrationWorkspace "register-deregister-stake-addr" $ \tempAbsBasePath' -> H.runWithDefaultWatchdog_ $ do -- Start a local test net conf@Conf { tempAbsPath } <- mkConf tempAbsBasePath' let tempAbsPath' = unTmpAbsPath tempAbsPath @@ -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..63fb3164dfb 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 @@ -33,8 +33,10 @@ import qualified Data.Text as Text import GHC.Exts (IsList (..)) import GHC.Stack import Lens.Micro +import System.Directory (makeAbsolute) import System.FilePath (()) +import Test.Cardano.CLI.Hash (serveFilesWhile) import Testnet.Components.Configuration import Testnet.Components.Query import Testnet.Defaults @@ -44,7 +46,7 @@ import Testnet.Process.Cli.Keys import qualified Testnet.Process.Cli.SPO as SPO import Testnet.Process.Cli.SPO (createStakeKeyRegistrationCertificate) import Testnet.Process.Cli.Transaction -import Testnet.Process.Run (execCli', mkExecConfig) +import Testnet.Process.Run (addEnvVarsToConfig, execCli', mkExecConfig) import Testnet.Property.Util (integrationWorkspace) import Testnet.Start.Types (GenesisOptions (..), cardanoNumPools) import Testnet.Types @@ -74,7 +76,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 @@ -106,17 +108,15 @@ hprop_constitutional_committee_add_new = integrationWorkspace "constitutional-co H.note_ $ "Foldblocks config file: " <> unFile configurationFile gov <- H.createDirectoryIfMissing $ work "governance" - proposalAnchorFp <- H.note $ gov "sample-proposal-anchor" - proposalDataFp <- H.note $ gov "sample-proposal-data" - updateCommitteeFp <- H.note $ gov "update-cc.action" - H.writeFile proposalAnchorFp $ - unlines [ "These are the reasons: " , "" , "1. First" , "2. Second " , "3. Third" ] - H.writeFile proposalDataFp "dummy proposal data" + let proposalAnchorDataIpfsHash = "QmexFJuEn5RtnHEqpxDcqrazdHPzAwe7zs2RxHLfMH5gBz" + proposalAnchorFile <- H.noteM $ liftIO $ makeAbsolute $ "test" "cardano-testnet-test" "files" "sample-proposal-anchor" + + updateCommitteeFp <- H.note $ gov "update-cc.action" proposalAnchorDataHash <- execCli' execConfig [ "hash", "anchor-data" - , "--file-text", proposalAnchorFp + , "--file-text", proposalAnchorFile ] let ccColdSKeyFp n = gov "cc-" <> show n <> "-cold.skey" @@ -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 $ @@ -180,30 +183,42 @@ hprop_constitutional_committee_add_new = integrationWorkspace "constitutional-co EpochNo epochNo <- H.noteShowM $ getCurrentEpochNo epochStateView let ccExpiryEpoch = epochNo + 200 - _ <- execCli' execConfig $ - [ eraName, "governance", "action" , "update-committee" - , "--testnet" - , "--anchor-url", "https://tinyurl.com/3wrwb2as" - , "--anchor-data-hash", proposalAnchorDataHash - , "--governance-action-deposit", show minGovActDeposit - , "--deposit-return-stake-verification-key-file", verificationKeyFp stakeKeys - , "--threshold", "0.2" - , "--out-file", updateCommitteeFp - ] - <> concatMap - (\fp -> ["--add-cc-cold-verification-key-file", fp, "--epoch", show ccExpiryEpoch]) - ccColdKeyFps + let relativeUrl = ["ipfs", proposalAnchorDataIpfsHash] txbodyFp <- H.note $ work "tx.body" txin1' <- findLargestUtxoForPaymentKey epochStateView sbe wallet0 - void $ execCli' execConfig - [ eraName, "transaction", "build" - , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet0 - , "--tx-in", Text.unpack $ renderTxIn txin1' - , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet0) <> "+" <> show @Int 5_000_000 - , "--proposal-file", updateCommitteeFp - , "--out-file", txbodyFp - ] + + -- Create temporary HTTP server with files required by the call to `cardano-cli` + -- In this case, the server emulates an IPFS gateway + serveFilesWhile + [(relativeUrl, proposalAnchorFile)] + ( \port -> do + let execConfig' = addEnvVarsToConfig execConfig [("IPFS_GATEWAY_URI", "http://localhost:" ++ show port ++ "/")] + + void $ execCli' execConfig' $ + [ eraName, "governance", "action" , "update-committee" + , "--testnet" + , "--anchor-url", "ipfs://" ++ proposalAnchorDataIpfsHash + , "--anchor-data-hash", proposalAnchorDataHash + , "--check-anchor-data" + , "--governance-action-deposit", show minGovActDeposit + , "--deposit-return-stake-verification-key-file", verificationKeyFp stakeKeys + , "--threshold", "0.2" + , "--out-file", updateCommitteeFp + ] + <> concatMap + (\fp -> ["--add-cc-cold-verification-key-file", fp, "--epoch", show ccExpiryEpoch]) + ccColdKeyFps + + void $ execCli' execConfig' + [ eraName, "transaction", "build" + , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet0 + , "--tx-in", Text.unpack $ renderTxIn txin1' + , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet0) <> "+" <> show @Int 5_000_000 + , "--proposal-file", updateCommitteeFp + , "--out-file", txbodyFp + ] + ) -- double check that we're starting with an empty committee committeeMembers <- getCommitteeMembers epochStateView ceo 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..a1f499356f5 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 @@ -24,6 +24,7 @@ import Prelude import Control.Monad import Control.Monad.Catch (MonadCatch) +import Control.Monad.Trans.Control (MonadBaseControl) import Data.Data (Typeable) import Data.Default.Class import qualified Data.Map as Map @@ -60,7 +61,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 @@ -197,8 +198,8 @@ hprop_check_drep_activity = integrationWorkspace "test-activity" $ \tempAbsBaseP -- and issues the specified votes using default DReps. Optionally, it also -- waits checks the expected effect of the proposal. activityChangeProposalTest - :: forall m t era . (HasCallStack, MonadTest m, MonadIO m, H.MonadAssertion m, MonadCatch m, Foldable t, Typeable era, - EraGov (ShelleyLedgerEra era), ConwayEraPParams (ShelleyLedgerEra era)) + :: forall m t era . (HasCallStack, MonadBaseControl IO m, MonadTest m, MonadIO m, H.MonadAssertion m, + MonadCatch m, Foldable t, Typeable era, EraGov (ShelleyLedgerEra era), ConwayEraPParams (ShelleyLedgerEra era)) => H.ExecConfig -- ^ Specifies the CLI execution configuration. -> EpochStateView -- ^ Current epoch state view for transaction building. It can be obtained -- using the 'getEpochStateView' function. @@ -219,7 +220,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..4c961ba4e2c 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 @@ -31,13 +31,15 @@ import Data.String import qualified Data.Text as Text import Data.Word import GHC.Stack +import System.Directory (makeAbsolute) import System.FilePath (()) +import Test.Cardano.CLI.Hash (serveFilesWhile) import Testnet.Components.Query import Testnet.Defaults import Testnet.Process.Cli.Keys import Testnet.Process.Cli.SPO (createStakeKeyRegistrationCertificate) -import Testnet.Process.Run (execCli', mkExecConfig) +import Testnet.Process.Run (addEnvVarsToConfig, execCli', mkExecConfig) import Testnet.Property.Util (integrationRetryWorkspace) import Testnet.Start.Types import Testnet.Types @@ -58,7 +60,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 } @@ -85,15 +87,14 @@ hprop_ledger_events_info_action = integrationRetryWorkspace 2 "info-hash" $ \tem H.note_ $ "Foldblocks config file: " <> unFile configurationFile gov <- H.createDirectoryIfMissing $ work "governance" - proposalAnchorFile <- H.note $ work gov "sample-proposal-anchor" - infoActionFp <- H.note $ work gov "info.action" - -- pls configure your editors to trim trailing whitespace >.> - H.writeFile proposalAnchorFile $ - unlines [ "These are the reasons: " , "" , "1. First" , "2. Second " , "3. Third" ] + let proposalAnchorDataIpfsHash = "QmexFJuEn5RtnHEqpxDcqrazdHPzAwe7zs2RxHLfMH5gBz" + proposalAnchorFile <- H.noteM $ liftIO $ makeAbsolute $ "test" "cardano-testnet-test" "files" "sample-proposal-anchor" + + infoActionFp <- H.note $ work gov "info.action" proposalAnchorDataHash <- execCli' execConfig - [ "hash", "anchor-data", "--file-text", proposalAnchorFile + [ "hash", "anchor-data", "--file-binary", proposalAnchorFile ] -- Register stake address @@ -134,31 +135,47 @@ hprop_ledger_events_info_action = integrationRetryWorkspace 2 "info-hash" $ \tem , "--tx-file", stakeCertTxSignedFp ] - -- Create info action proposal + -- make sure that stake registration cert gets into a block + _ <- waitForBlocks epochStateView 1 - void $ execCli' execConfig - [ eraName, "governance", "action", "create-info" - , "--testnet" - , "--governance-action-deposit", show @Int 1_000_000 -- TODO: Get this from the node - , "--deposit-return-stake-verification-key-file", verificationKeyFp stakeKeys - , "--anchor-url", "https://tinyurl.com/3wrwb2as" - , "--anchor-data-hash", proposalAnchorDataHash - , "--out-file", infoActionFp - ] + let relativeUrl = ["ipfs", proposalAnchorDataIpfsHash] txbodyFp <- H.note $ work "tx.body" txbodySignedFp <- H.note $ work "tx.body.signed" - txin2 <- findLargestUtxoForPaymentKey epochStateView sbe wallet1 - - H.noteM_ $ execCli' execConfig - [ eraName, "transaction", "build" - , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet1 - , "--tx-in", Text.unpack $ renderTxIn txin2 - , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet0) <> "+" <> show @Int 5_000_000 - , "--proposal-file", infoActionFp - , "--out-file", txbodyFp - ] + -- Create temporary HTTP server with files required by the call to `cardano-cli` + -- In this case, the server emulates an IPFS gateway + serveFilesWhile + [(relativeUrl, proposalAnchorFile)] + ( \port -> do + let execConfig' = addEnvVarsToConfig execConfig [("IPFS_GATEWAY_URI", "http://localhost:" ++ show port ++ "/")] + + void $ + execCli' + execConfig' + [ eraName, "governance", "action", "create-info" + , "--testnet" + , "--governance-action-deposit", show @Int 1_000_000 -- TODO: Get this from the node + , "--deposit-return-stake-verification-key-file", verificationKeyFp stakeKeys + , "--anchor-url", "ipfs://" ++ proposalAnchorDataIpfsHash + , "--anchor-data-hash", proposalAnchorDataHash + , "--check-anchor-data" + , "--out-file", infoActionFp + ] + + txin2 <- findLargestUtxoForPaymentKey epochStateView sbe wallet1 + + void $ + execCli' + execConfig' + [ eraName, "transaction", "build" + , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet1 + , "--tx-in", Text.unpack $ renderTxIn txin2 + , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet0) <> "+" <> show @Int 5_000_000 + , "--proposal-file", infoActionFp + , "--out-file", txbodyFp + ] + ) void $ execCli' execConfig [ eraName, "transaction", "sign" 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..716c46c8ba9 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 @@ -30,8 +30,10 @@ import Data.String import qualified Data.Text as Text import GHC.Exts (IsList (..)) import Lens.Micro +import System.Directory (makeAbsolute) import System.FilePath (()) +import Test.Cardano.CLI.Hash (serveFilesWhile) import Testnet.Components.Configuration import Testnet.Components.Query import Testnet.Defaults @@ -40,7 +42,7 @@ import Testnet.Process.Cli.DRep import Testnet.Process.Cli.Keys import Testnet.Process.Cli.SPO (createStakeKeyRegistrationCertificate) import Testnet.Process.Cli.Transaction -import Testnet.Process.Run (execCli', mkExecConfig) +import Testnet.Process.Run (addEnvVarsToConfig, execCli', mkExecConfig) import Testnet.Property.Util (integrationWorkspace) import Testnet.Start.Types import Testnet.Types @@ -70,7 +72,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 @@ -102,21 +104,19 @@ hprop_ledger_events_propose_new_constitution = integrationWorkspace "propose-new -- Create Conway constitution gov <- H.createDirectoryIfMissing $ work "governance" - proposalAnchorFile <- H.note $ gov "sample-proposal-anchor" - constitutionFile <- H.note $ gov "sample-constitution" constitutionActionFp <- H.note $ gov "constitution.action" - H.writeFile proposalAnchorFile $ - unlines [ "These are the reasons: " , "" , "1. First" , "2. Second " , "3. Third" ] - H.copyFile - "test/cardano-testnet-test/files/input/sample-constitution.txt" - constitutionFile + let proposalAnchorDataIpfsHash = "QmexFJuEn5RtnHEqpxDcqrazdHPzAwe7zs2RxHLfMH5gBz" + proposalAnchorFile <- H.noteM $ liftIO $ makeAbsolute $ "test" "cardano-testnet-test" "files" "sample-proposal-anchor" + let constitutionAnchorDataIpfsHash = "QmXGkenkhh3NsotVwbNGToGsPuvJLgRT9aAz5ToyKAqdWP" + constitutionAnchorFile <- H.noteM $ liftIO $ makeAbsolute $ "test" "cardano-testnet-test" "files" "sample-proposal-anchor" + constitutionHash <- execCli' execConfig - [ "hash", "anchor-data", "--file-text", constitutionFile + [ "hash", "anchor-data", "--file-binary", constitutionAnchorFile ] proposalAnchorDataHash <- execCli' execConfig - [ "hash", "anchor-data", "--file-text", proposalAnchorFile + [ "hash", "anchor-data", "--file-binary", proposalAnchorFile ] -- Register stake address @@ -169,33 +169,48 @@ hprop_ledger_events_propose_new_constitution = integrationWorkspace "propose-new , "--script-file", guardRailScriptFp ] - minDRepDeposit <- getMinDRepDeposit epochStateView ceo - void $ execCli' execConfig - [ "conway", "governance", "action", "create-constitution" - , "--testnet" - , "--governance-action-deposit", show minDRepDeposit - , "--deposit-return-stake-verification-key-file", verificationKeyFp stakeKeys - , "--anchor-url", "https://tinyurl.com/3wrwb2as" - , "--anchor-data-hash", proposalAnchorDataHash - , "--constitution-url", "https://tinyurl.com/2pahcy6z" - , "--constitution-hash", constitutionHash - , "--constitution-script-hash", constitutionScriptHash - , "--out-file", constitutionActionFp - ] + let relativeUrlProposal = ["ipfs", proposalAnchorDataIpfsHash] + relativeUrlConstitution = ["ipfs", constitutionAnchorDataIpfsHash] txbodyFp <- H.note $ work "tx.body" + minDRepDeposit <- getMinDRepDeposit epochStateView ceo - H.noteShowM_ $ waitForBlocks epochStateView 1 - txin2 <- findLargestUtxoForPaymentKey epochStateView sbe wallet1 - - void $ execCli' execConfig - [ "conway", "transaction", "build" - , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet1 - , "--tx-in", Text.unpack $ renderTxIn txin2 - , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet0) <> "+" <> show @Int 5_000_000 - , "--proposal-file", constitutionActionFp - , "--out-file", txbodyFp + -- Create temporary HTTP server with files required by the call to `cardano-cli` + -- In this case, the server emulates an IPFS gateway + serveFilesWhile + [ (relativeUrlProposal, proposalAnchorFile) + , (relativeUrlConstitution, constitutionAnchorFile) ] + ( \port -> do + let execConfig' = addEnvVarsToConfig execConfig [("IPFS_GATEWAY_URI", "http://localhost:" ++ show port ++ "/")] + + void $ execCli' execConfig' + [ "conway", "governance", "action", "create-constitution" + , "--testnet" + , "--governance-action-deposit", show minDRepDeposit + , "--deposit-return-stake-verification-key-file", verificationKeyFp stakeKeys + , "--anchor-url", "ipfs://" ++ proposalAnchorDataIpfsHash + , "--anchor-data-hash", proposalAnchorDataHash + , "--check-anchor-data" + , "--constitution-url", "ipfs://" ++ constitutionAnchorDataIpfsHash + , "--constitution-hash", constitutionHash + , "--check-constitution-hash" + , "--constitution-script-hash", constitutionScriptHash + , "--out-file", constitutionActionFp + ] + + H.noteShowM_ $ waitForBlocks epochStateView 1 + txin2 <- findLargestUtxoForPaymentKey epochStateView sbe wallet1 + + void $ execCli' execConfig' + [ "conway", "transaction", "build" + , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet1 + , "--tx-in", Text.unpack $ renderTxIn txin2 + , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet0) <> "+" <> show @Int 5_000_000 + , "--proposal-file", constitutionActionFp + , "--out-file", txbodyFp + ] + ) signedProposalTx <- signTx execConfig cEra gov "signed-proposal" (File txbodyFp) [Some $ paymentKeyInfoPair wallet1] 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/Transaction/HashMismatch.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/Transaction/HashMismatch.hs new file mode 100644 index 00000000000..25e9e2eed2c --- /dev/null +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/Transaction/HashMismatch.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Testnet.Test.Gov.Transaction.HashMismatch + ( hprop_transaction_build_wrong_hash + ) where + +import Cardano.Api as Api +import Cardano.Api.Ledger (Coin (unCoin)) + +import Cardano.Testnet + +import Prelude + +import Control.Monad +import Data.Default.Class +import qualified Data.Text as Text +import GHC.IO.Exception (ExitCode (ExitFailure)) +import System.Directory (makeAbsolute) +import System.FilePath (()) + +import Test.Cardano.CLI.Hash (serveFilesWhile, tamperBase16Hash) +import Testnet.Components.Query +import Testnet.Process.Cli.Keys +import Testnet.Process.Run (addEnvVarsToConfig, execCli', execCliAny, mkExecConfig) +import Testnet.Property.Util (integrationRetryWorkspace) +import Testnet.Start.Types +import Testnet.Types + +import Hedgehog +import qualified Hedgehog as H +import qualified Hedgehog.Extras as H + +-- | Execute me with: +-- @DISABLE_RETRIES=1 cabal test cardano-testnet-test --test-options '-p "/Transaction Build Wrong Hash/'@ +hprop_transaction_build_wrong_hash :: Property +hprop_transaction_build_wrong_hash = integrationRetryWorkspace 2 "wrong-hash" $ \tempAbsBasePath' -> H.runWithDefaultWatchdog_ $ do + + conf@Conf { tempAbsPath } <- H.noteShowM $ mkConf tempAbsBasePath' + let tempAbsPath' = unTmpAbsPath tempAbsPath + tempBaseAbsPath = makeTmpBaseAbsPath tempAbsPath + + work <- H.createDirectoryIfMissing $ tempAbsPath' "work" + + let ceo = ConwayEraOnwardsConway + sbe = convert ceo + asbe = AnyShelleyBasedEra sbe + eraName = eraToString sbe + fastTestnetOptions = def { cardanoNodeEra = asbe } + shelleyOptions = def { genesisEpochLength = 200 } + + TestnetRuntime + { testnetMagic + , testnetNodes + , wallets=wallet0:wallet1:_ + , configurationFile + } + <- cardanoTestnetDefault fastTestnetOptions shelleyOptions conf + + node <- H.headM testnetNodes + poolSprocket1 <- H.noteShow $ nodeSprocket node + execConfig <- mkExecConfig tempBaseAbsPath poolSprocket1 testnetMagic + let socketPath = nodeSocketPath node + + epochStateView <- getEpochStateView configurationFile socketPath + + H.note_ $ "Sprocket: " <> show poolSprocket1 + H.note_ $ "Abs path: " <> tempAbsBasePath' + H.note_ $ "Socketpath: " <> unFile socketPath + H.note_ $ "Foldblocks config file: " <> unFile configurationFile + + gov <- H.createDirectoryIfMissing $ work "governance" + + let proposalAnchorDataIpfsHash = "QmexFJuEn5RtnHEqpxDcqrazdHPzAwe7zs2RxHLfMH5gBz" + proposalAnchorFile <- H.noteM $ liftIO $ makeAbsolute $ "test" "cardano-testnet-test" "files" "sample-proposal-anchor" + + infoActionFp <- H.note $ work gov "info.action" + + proposalAnchorDataHash <- execCli' execConfig + [ "hash", "anchor-data", "--file-binary", proposalAnchorFile + ] + + let stakeVkeyFp = gov "stake.vkey" + stakeSKeyFp = gov "stake.skey" + stakeCertFp = gov "stake.regcert" + stakeKeys = KeyPair { verificationKey = File stakeVkeyFp + , signingKey = File stakeSKeyFp + } + + cliStakeAddressKeyGen stakeKeys + + -- Register stake address + keyDeposit <- getKeyDeposit epochStateView ceo + + void $ execCli' execConfig + [ eraName, "stake-address", "registration-certificate" + , "--stake-verification-key-file", stakeVkeyFp + , "--key-reg-deposit-amt", show $ unCoin keyDeposit + , "--out-file", stakeCertFp + ] + + stakeCertTxBodyFp <- H.note $ work "stake.registration.txbody" + stakeCertTxSignedFp <- H.note $ work "stake.registration.tx" + + txin1 <- findLargestUtxoForPaymentKey epochStateView sbe wallet0 + + void $ execCli' execConfig + [ eraName, "transaction", "build" + , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet0 + , "--tx-in", Text.unpack $ renderTxIn txin1 + , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet1) <> "+" <> show @Int 10_000_000 + , "--certificate-file", stakeCertFp + , "--witness-override", show @Int 2 + , "--out-file", stakeCertTxBodyFp + ] + + void $ execCli' execConfig + [ eraName, "transaction", "sign" + , "--tx-body-file", stakeCertTxBodyFp + , "--signing-key-file", signingKeyFp $ paymentKeyInfoPair wallet0 + , "--signing-key-file", stakeSKeyFp + , "--out-file", stakeCertTxSignedFp + ] + + void $ execCli' execConfig + [ eraName, "transaction", "submit" + , "--tx-file", stakeCertTxSignedFp + ] + + let relativeUrl = ["ipfs", proposalAnchorDataIpfsHash] + + txbodyFp <- H.note $ work "tx.body" + + tamperedHash <- H.evalMaybe $ tamperBase16Hash proposalAnchorDataHash + + -- Create temporary HTTP server with files required by the call to `cardano-cli` + -- In this case, the server emulates an IPFS gateway + serveFilesWhile + [(relativeUrl, proposalAnchorFile)] + ( \port -> do + let execConfig' = addEnvVarsToConfig execConfig [("IPFS_GATEWAY_URI", "http://localhost:" ++ show port ++ "/")] + + minDepositAmount <- getMinGovActionDeposit epochStateView ceo + + void $ + execCli' + execConfig' + [ eraName, "governance", "action", "create-info" + , "--testnet" + , "--governance-action-deposit", show minDepositAmount + , "--deposit-return-stake-verification-key-file", stakeVkeyFp + , "--anchor-url", "ipfs://" ++ proposalAnchorDataIpfsHash + , "--anchor-data-hash", tamperedHash + , "--out-file", infoActionFp + ] + + txin2 <- findLargestUtxoForPaymentKey epochStateView sbe wallet1 + + (exitCode, _, stderrOutput) <- + execCliAny + execConfig' + [ eraName, "transaction", "build" + , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet1 + , "--tx-in", Text.unpack $ renderTxIn txin2 + , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet0) <> "+" <> show @Int 5_000_000 + , "--proposal-file", infoActionFp + , "--out-file", txbodyFp + ] + + exitCode H.=== ExitFailure 1 + + H.note_ stderrOutput + + H.assertWith (Text.pack stderrOutput) ("Hashes do not match!" `Text.isInfixOf`) + ) 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..586948cba13 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 @@ -35,13 +35,15 @@ import qualified Data.Map.Strict as M import qualified Data.Text as Text import GHC.Stack import Lens.Micro +import System.Directory (makeAbsolute) import System.FilePath (()) +import Test.Cardano.CLI.Hash (serveFilesWhile) import Testnet.Components.Query import Testnet.Defaults import Testnet.Process.Cli.Keys (cliStakeAddressKeyGen) import Testnet.Process.Cli.SPO (createStakeKeyRegistrationCertificate) -import Testnet.Process.Run (execCli', mkExecConfig) +import Testnet.Process.Run (addEnvVarsToConfig, execCli', mkExecConfig) import Testnet.Property.Util (integrationRetryWorkspace) import Testnet.Start.Types import Testnet.Types @@ -58,7 +60,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 @@ -88,15 +90,14 @@ hprop_ledger_events_treasury_withdrawal = integrationRetryWorkspace 2 "treasury H.note_ $ "Foldblocks config file: " <> unFile configurationFile gov <- H.createDirectoryIfMissing $ work "governance" - proposalAnchorFile <- H.note $ work gov "sample-proposal-anchor" - treasuryWithdrawalActionFp <- H.note $ work gov "treasury-withdrawal.action" - -- pls configure your editors to trim trailing whitespace >.> - H.writeFile proposalAnchorFile $ - unlines [ "These are the reasons: " , "" , "1. First" , "2. Second " , "3. Third" ] + let proposalAnchorDataIpfsHash = "QmexFJuEn5RtnHEqpxDcqrazdHPzAwe7zs2RxHLfMH5gBz" + proposalAnchorFile <- H.noteM $ liftIO $ makeAbsolute $ "test" "cardano-testnet-test" "files" "sample-proposal-anchor" + + treasuryWithdrawalActionFp <- H.note $ work gov "treasury-withdrawal.action" proposalAnchorDataHash <- execCli' execConfig - [ "hash", "anchor-data", "--file-text", proposalAnchorFile + [ "hash", "anchor-data", "--file-binary", proposalAnchorFile ] txin2 <- findLargestUtxoForPaymentKey epochStateView sbe wallet1 @@ -142,35 +143,45 @@ hprop_ledger_events_treasury_withdrawal = integrationRetryWorkspace 2 "treasury -- {{{ Create treasury withdrawal let withdrawalAmount = 3_300_777 :: Integer govActionDeposit <- getMinDRepDeposit epochStateView ceo - void $ execCli' execConfig - [ eraName, "governance", "action", "create-treasury-withdrawal" - , "--testnet" - , "--anchor-url", "https://tinyurl.com/3wrwb2as" - , "--anchor-data-hash", proposalAnchorDataHash - , "--governance-action-deposit", show govActionDeposit - , "--deposit-return-stake-verification-key-file", verificationKeyFp stakeKeys - , "--transfer", show withdrawalAmount - , "--funds-receiving-stake-verification-key-file", verificationKeyFp stakeKeys - , "--out-file", treasuryWithdrawalActionFp - ] + let relativeUrl = ["ipfs", proposalAnchorDataIpfsHash] txbodyFp <- H.note $ work "tx.body" txbodySignedFp <- H.note $ work "tx.body.signed" - -- wait for one block before using wallet0 again - _ <- waitForBlocks epochStateView 1 - txin3 <- findLargestUtxoForPaymentKey epochStateView sbe wallet0 - - void $ execCli' execConfig - [ eraName, "transaction", "build" - , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet0 - , "--tx-in", Text.unpack $ renderTxIn txin3 - , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet1) <> "+" <> show @Int 5_000_000 - , "--proposal-file", treasuryWithdrawalActionFp - , "--out-file", txbodyFp - ] + -- Create temporary HTTP server with files required by the call to `cardano-cli` + -- In this case, the server emulates an IPFS gateway + serveFilesWhile + [(relativeUrl, proposalAnchorFile)] + ( \port -> do + let execConfig' = addEnvVarsToConfig execConfig [("IPFS_GATEWAY_URI", "http://localhost:" ++ show port ++ "/")] + void $ execCli' execConfig' + [ eraName, "governance", "action", "create-treasury-withdrawal" + , "--testnet" + , "--anchor-url", "ipfs://" ++ proposalAnchorDataIpfsHash + , "--anchor-data-hash", proposalAnchorDataHash + , "--governance-action-deposit", show govActionDeposit + , "--deposit-return-stake-verification-key-file", verificationKeyFp stakeKeys + , "--transfer", show withdrawalAmount + , "--funds-receiving-stake-verification-key-file", verificationKeyFp stakeKeys + , "--out-file", treasuryWithdrawalActionFp + ] + + -- wait for one block before using wallet0 again + _ <- waitForBlocks epochStateView 1 + + txin3 <- findLargestUtxoForPaymentKey epochStateView sbe wallet0 + + void $ execCli' execConfig' + [ eraName, "transaction", "build" + , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet0 + , "--tx-in", Text.unpack $ renderTxIn txin3 + , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet1) <> "+" <> show @Int 5_000_000 + , "--proposal-file", treasuryWithdrawalActionFp + , "--out-file", txbodyFp + ] + ) void $ execCli' execConfig [ eraName, "transaction", "sign" 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..8aeed6e8466 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 @@ -17,6 +17,7 @@ import qualified Cardano.Testnet as Testnet import Prelude +import Control.Applicative (Alternative ((<|>))) import Control.Monad import Data.Aeson import Data.Aeson.Types @@ -91,13 +92,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 +121,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) @@ -224,10 +228,9 @@ hprop_shutdownOnSlotSynced = integrationRetryWorkspace 2 "shutdown-on-slot-synce mExitCodeRunning === Right ExitSuccess logs <- H.readFile (nodeStdout node) - slotTip <- case mapMaybe parseMsg $ reverse $ lines logs of - [] -> H.failMessage callStack "Could not find close DB message." - (Left err):_ -> H.failMessage callStack err - (Right s):_ -> return s + slotTip <- case findLastSlot . reverse $ lines logs of + Nothing -> H.failMessage callStack "Could not find close DB message." + Just s -> return s let epsilon = 50 H.assertWithinTolerance slotTip maxSlot epsilon @@ -261,22 +264,32 @@ hprop_shutdownOnSigint = integrationRetryWorkspace 2 "shutdown-on-sigint" $ \tem other -> H.failMessage callStack $ "Unexpected exit status for the testnet process: " <> show other logs <- H.readFile nodeStdout - case mapMaybe parseMsg $ reverse $ lines logs of - [] -> H.failMessage callStack "Could not find close DB message." - (Left err):_ -> H.failMessage callStack err - (Right _):_ -> pure () - - -parseMsg :: String -> Maybe (Either String Integer) -parseMsg line = case decode $ LBS.pack line of - Nothing -> Just $ Left $ "Expected JSON formated log message, but got: " ++ line - Just obj -> Right <$> parseMaybe parseTipSlot obj - -parseTipSlot :: Object -> Parser Integer -parseTipSlot obj = do - body <- obj .: "data" - tip <- body .: "tip" - kind <- body .: "kind" - if kind == ("TraceOpenEvent.ClosedDB" :: String) - then tip .: "slot" - else mzero + case findLastSlot . reverse $ lines logs of + Nothing -> H.failMessage callStack "Could not find close DB message." + _ -> pure () + + +findLastSlot :: [String] -> Maybe Int +findLastSlot = go (False, Nothing) + where + go (_, mSlot) [] = mSlot + go (True, mSlot@(Just _)) _ = mSlot + go r@(isDbClosed, mSlot) (line:ls) = do + let mLineVal = decode $ LBS.pack line + case mLineVal of + -- ignore non-json lines + Nothing -> go r ls + Just obj -> do + let isDbClosed' = isDbClosed || (parseMaybe parseDbClosed obj == Just True) + mSlot' = mSlot <|> parseMaybe parseSlot obj + go (isDbClosed', mSlot') ls + + parseDbClosed obj = do + body <- obj .: "data" + kind <- body .: "kind" + pure $ kind == ("DBClosed" :: String) + + parseSlot obj = do + body <- obj .: "data" + body .: "slot" :: Parser Int + diff --git a/cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs b/cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs index 8e993360147..0afabc4625c 100644 --- a/cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs +++ b/cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs @@ -20,6 +20,7 @@ import qualified Cardano.Testnet.Test.Gov.GovActionTimeout as Gov import qualified Cardano.Testnet.Test.Gov.InfoAction as LedgerEvents import qualified Cardano.Testnet.Test.Gov.PParamChangeFailsSPO as Gov import qualified Cardano.Testnet.Test.Gov.ProposeNewConstitution as Gov +import qualified Cardano.Testnet.Test.Gov.Transaction.HashMismatch as WrongHash import qualified Cardano.Testnet.Test.Gov.TreasuryDonation as Gov import qualified Cardano.Testnet.Test.Gov.TreasuryWithdrawal as Gov import qualified Cardano.Testnet.Test.Node.Shutdown @@ -68,6 +69,7 @@ tests = do , ignoreOnMacAndWindows "Treasury Withdrawal" Gov.hprop_ledger_events_treasury_withdrawal , ignoreOnWindows "PParam change fails for SPO" Gov.hprop_check_pparam_fails_spo , ignoreOnWindows "InfoAction" LedgerEvents.hprop_ledger_events_info_action + , ignoreOnWindows "Transaction Build Wrong Hash" WrongHash.hprop_transaction_build_wrong_hash ] , T.testGroup "Plutus" [ ignoreOnWindows "PlutusV3" Cardano.Testnet.Test.Cli.Conway.Plutus.hprop_plutus_v3] 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-testnet/test/cardano-testnet-test/files/sample-constitution-anchor b/cardano-testnet/test/cardano-testnet-test/files/sample-constitution-anchor new file mode 100644 index 00000000000..4dbb452e8e6 --- /dev/null +++ b/cardano-testnet/test/cardano-testnet-test/files/sample-constitution-anchor @@ -0,0 +1,50 @@ +Preamble + +We, the zaniest inhabitants of the peculiar and bewildering land of Barataria, in honor of our illustrious Governor, Sancho Panza, renowned for his comically charming ordinances, do hereby present this Constitution to tickle your fancy and uphold the values of laughter, merriment, and the pursuit of hilarity for all our citizens. + +Article I: The Right to Absurdity + +Wine-Watering Rights: Every Baratarian shall have the inalienable right to water down their wine as they see fit, provided they can still manage a tipsy jig. + +Fashion Freedom: Citizens are encouraged to dress inappropriately for the sheer joy of it, as long as it does not involve the use of sharp objects, poisonous animals, or explosives. + +Article II: The Role of Government: Keeping It Lighthearted + +Official Clown: There shall be an official court jester whose duty is to make the Governor laugh at least once a day. Failure to amuse may result in banishment to a neighboring kingdom. + +Puns and Pranks: All government proceedings shall include at least one pun and one harmless prank per session to maintain the mirthful spirit of Barataria. + +Article III: The Economic Circus + +Foolish Redistribution: The government shall engage in a monthly "wealth lottery," redistributing riches by catapulting bags of gold into the air and letting them fall where they may. + +Tax Deductions for Silly Hats: Citizens who wear absurd hats shall receive generous tax deductions, fostering creativity and fashion-forward thinking. + +Article IV: Justice, Comedy, and the Absurd + +Trial by Tickling: In the interest of justice and merriment, all trials shall include a "tickle test" to determine guilt or innocence. Giggles are considered a sign of innocence. + +Innocent Until Proven Clueless: It shall be presumed that every Baratarian is innocent of any wrongdoing until they can convincingly demonstrate their utter cluelessness in court. + +Article V: Education and Clown Colleges + +Clown Colleges for All: Barataria shall establish Clown Colleges to ensure that every citizen has the opportunity to master the art of clowning and perform slapstick humor. + +Silly Science: Research grants shall be awarded to projects that explore the science of whoopee cushions, banana peels, and rubber chickens. + +Article VI: Defense and Pranks + +Pillow Fort Defense: Barataria's defense strategy shall revolve around building impregnable pillow forts and inviting would-be invaders to epic pillow fights to resolve conflicts. + +War Declarations through Whoopie Cushions: Before declaring war, Barataria shall send a diplomatic envoy to the offending nation armed only with whoopee cushions to express our discontent. + +Article VII: Amendments and Clown-novations + +Whimsical Amendments: Amendments to this Constitution shall be proposed in the form of a joke or a riddle, and they must receive a hearty laugh from at least three-quarters of the citizens to be adopted. +Article VIII: Final Pratfalls + +Ratification with a Pie in the Face: This Constitution shall be ratified in a grand ceremony involving a pie in the face of the official ratifier, ensuring a silly and sticky beginning for Barataria. + +Effective Clowning Date: This Constitution shall come into effect immediately upon the eruption of the first uncontrollable fit of laughter. + +In witness whereof, we, the undersigned jesters, pranksters, and merrymakers, do hereby establish and adopt this Constitution to make Barataria a haven of hilarity, where laughter reigns supreme, and seriousness is only allowed on April Fool's Day. \ No newline at end of file diff --git a/cardano-testnet/test/cardano-testnet-test/files/sample-proposal-anchor b/cardano-testnet/test/cardano-testnet-test/files/sample-proposal-anchor new file mode 100644 index 00000000000..5ccd92f3867 --- /dev/null +++ b/cardano-testnet/test/cardano-testnet-test/files/sample-proposal-anchor @@ -0,0 +1,5 @@ +These are the reasons: + +1. First +2. Second +3. Third diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 7f6efc072d3..78c8e651187 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -170,14 +170,15 @@ library , contra-tracer , directory , ekg-core - , ekg-forward >= 0.5 + , ekg-forward >= 0.8 , ekg-wai , extra , filepath , http-types , mime-mail + , network-mux , optparse-applicative - , ouroboros-network ^>= 0.17 + , ouroboros-network ^>= 0.19 , 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/src/Cardano/Tracer/Handlers/Notifications/Send.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/Notifications/Send.hs index 391489ae37d..9e5a918858c 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/Notifications/Send.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/Notifications/Send.hs @@ -4,7 +4,8 @@ module Cardano.Tracer.Handlers.Notifications.Send ( makeAndSendNotification ) where -import Cardano.Logging (showT) +import Cardano.Logging (Trace, showT) +import Cardano.Tracer.MetaTrace (TracerTrace(..)) import Cardano.Tracer.Handlers.Notifications.Email import Cardano.Tracer.Handlers.Notifications.Types import Cardano.Tracer.Types @@ -23,20 +24,21 @@ import Data.Time.Clock (UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) makeAndSendNotification - :: EmailSettings + :: Trace IO TracerTrace + -> EmailSettings -> ConnectedNodesNames -> DataPointRequestors -> Lock -> TVar UTCTime -> EventsQueue -> IO () -makeAndSendNotification emailSettings connectedNodesNames dpRequestors +makeAndSendNotification tracer emailSettings connectedNodesNames dpRequestors currentDPLock lastTime eventsQueue = do events <- atomically $ nub <$> flushTBQueue eventsQueue let (nodeIds, tss) = unzip $ nub [(nodeId, ts) | Event nodeId ts _ _ <- events] unless (null nodeIds) $ do nodeNames <- - forM nodeIds $ askNodeNameRaw connectedNodesNames dpRequestors currentDPLock + forM nodeIds $ askNodeNameRaw tracer connectedNodesNames dpRequestors currentDPLock lastEventTime <- readTVarIO lastTime let onlyNewEvents = filter (\(Event _ ts _ _) -> ts > lastEventTime) events sendNotification emailSettings onlyNewEvents $ zip nodeIds nodeNames diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/Notifications/Utils.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/Notifications/Utils.hs index a471c1f4c87..aee4e91a755 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/Notifications/Utils.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/Notifications/Utils.hs @@ -7,11 +7,13 @@ module Cardano.Tracer.Handlers.Notifications.Utils , updateNotificationsPeriods ) where +import Cardano.Logging (Trace) import Cardano.Tracer.Handlers.Notifications.Send import Cardano.Tracer.Handlers.Notifications.Settings import Cardano.Tracer.Handlers.Notifications.Timer import Cardano.Tracer.Handlers.Notifications.Types import Cardano.Tracer.Handlers.Utils +import Cardano.Tracer.MetaTrace (TracerTrace(..)) import Cardano.Tracer.Types import Control.Concurrent.Extra (Lock) @@ -23,12 +25,13 @@ import Control.Monad.Extra (unlessM, whenJust) import qualified Data.Map.Strict as M initEventsQueues - :: Maybe FilePath + :: Trace IO TracerTrace + -> Maybe FilePath -> ConnectedNodesNames -> DataPointRequestors -> Lock -> IO EventsQueues -initEventsQueues rtvSD nodesNames dpReqs curDPLock = do +initEventsQueues tracer rtvSD nodesNames dpReqs curDPLock = do emailSettings <- readSavedEmailSettings rtvSD newTVarIO . M.fromList =<< @@ -39,7 +42,7 @@ initEventsQueues rtvSD nodesNames dpReqs curDPLock = do let mkEventQueue ident (evsS, evsP) = do evsQ <- newTBQueueIO 2000 evsT <- mkTimer - (makeAndSendNotification emailSettings nodesNames dpReqs curDPLock lastTime evsQ) evsS evsP + (makeAndSendNotification tracer emailSettings nodesNames dpReqs curDPLock lastTime evsQ) evsS evsP pure (ident, (evsQ, evsT)) settings <- readSavedEventsSettings rtvSD diff --git a/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs b/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs index 9abd834affc..6289be39873 100644 --- a/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs +++ b/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs @@ -23,6 +23,7 @@ module Cardano.Tracer.MetaTrace import Cardano.Logging import Cardano.Logging.Resources import Cardano.Tracer.Configuration +import Cardano.Tracer.Types (NodeId(..), NodeName) import Data.Aeson hiding (Error) import qualified Data.Aeson as AE @@ -49,6 +50,9 @@ data TracerTrace | TracerInitStarted | TracerInitEventQueues | TracerInitDone + | TracerAddNewNodeIdMapping + { ttBimapping :: !(NodeId, NodeName) + } | TracerStartedLogRotator | TracerStartedPrometheus { ttPrometheusEndpoint :: !Endpoint @@ -107,6 +111,11 @@ instance ToJSON TracerTrace where TracerInitDone -> concatPairs [ "kind" .= txt "TracerInitDone" ] + TracerAddNewNodeIdMapping (NodeId nodeId, nodeName) -> concatPairs + [ "kind" .= txt "TracerAddNewNodeIdMapping" + , "nodeId" .= txt nodeId + , "nodeName" .= txt nodeName + ] TracerStartedLogRotator -> concatPairs [ "kind" .= txt "TracerStartedLogRotator" ] @@ -204,6 +213,7 @@ instance MetaTrace TracerTrace where namespaceFor TracerInitStarted = Namespace [] ["InitStart"] namespaceFor TracerInitEventQueues = Namespace [] ["EventQueues"] namespaceFor TracerInitDone = Namespace [] ["InitDone"] + namespaceFor TracerAddNewNodeIdMapping {} = Namespace [] ["AddNewNodeIdMapping"] namespaceFor TracerStartedLogRotator = Namespace [] ["StartedLogRotator"] namespaceFor TracerStartedPrometheus{} = Namespace [] ["StartedPrometheus"] namespaceFor TracerStartedMonitoring{} = Namespace [] ["StartedMonitoring"] @@ -225,6 +235,7 @@ instance MetaTrace TracerTrace where severityFor (Namespace _ ["InitStart"]) _ = Just Info severityFor (Namespace _ ["EventQueues"]) _ = Just Info severityFor (Namespace _ ["InitDone"]) _ = Just Info + severityFor (Namespace _ ["AddNewNodeIdMapping"]) _ = Just Info severityFor (Namespace _ ["StartedLogRotator"]) _ = Just Info severityFor (Namespace _ ["StartedPrometheus"]) _ = Just Info severityFor (Namespace _ ["StartedMonitoring"]) _ = Just Info @@ -250,6 +261,7 @@ instance MetaTrace TracerTrace where , Namespace [] ["InitStart"] , Namespace [] ["EventQueues"] , Namespace [] ["InitDone"] + , Namespace [] ["AddNewNodeIdMapping"] , Namespace [] ["StartedLogRotator"] , Namespace [] ["StartedPrometheus"] , Namespace [] ["StartedMonitoring"] diff --git a/cardano-tracer/src/Cardano/Tracer/Types.hs b/cardano-tracer/src/Cardano/Tracer/Types.hs index ccd095c4b37..312958649c0 100644 --- a/cardano-tracer/src/Cardano/Tracer/Types.hs +++ b/cardano-tracer/src/Cardano/Tracer/Types.hs @@ -16,8 +16,10 @@ module Cardano.Tracer.Types import Cardano.Tracer.Configuration + import Control.Concurrent.MVar (MVar) import Control.Concurrent.STM.TVar (TVar) +import Data.Aeson (ToJSON) import Data.Bimap (Bimap) import Data.Kind import Data.Map.Strict (Map) @@ -32,7 +34,8 @@ import Trace.Forward.Utils.DataPoint (DataPointRequestor) -- | Unique identifier of connected node, based on 'remoteAddress' from -- 'ConnectionId', please see 'ouroboros-network'. newtype NodeId = NodeId Text - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON) type NodeName = Text diff --git a/cardano-tracer/src/Cardano/Tracer/Utils.hs b/cardano-tracer/src/Cardano/Tracer/Utils.hs index 39ca20b3964..e4c0af37525 100644 --- a/cardano-tracer/src/Cardano/Tracer/Utils.hs +++ b/cardano-tracer/src/Cardano/Tracer/Utils.hs @@ -45,9 +45,12 @@ import Cardano.Node.Startup (NodeInfo (..)) import Cardano.Tracer.Configuration import Cardano.Tracer.Environment import Cardano.Tracer.Handlers.Utils +import qualified Cardano.Logging as Tracer (traceWith) +import Cardano.Tracer.MetaTrace hiding (traceWith) import Cardano.Tracer.Types import Ouroboros.Network.Socket (ConnectionId (..)) + #if MIN_VERSION_base(4,18,0) -- Do not know why. import Control.Applicative (liftA3) @@ -59,7 +62,7 @@ import Control.Concurrent.Async (Concurrently(..)) import Control.Concurrent.Extra (Lock) import Control.Concurrent.MVar (newMVar, swapMVar, readMVar, tryReadMVar, modifyMVar_) import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVarIO) +import Control.Concurrent.STM.TVar (modifyTVar', stateTVar, readTVarIO, newTVarIO) import Control.Exception (SomeAsyncException (..), SomeException, finally, fromException, try, tryJust) import Control.Monad (forM_) @@ -67,7 +70,8 @@ import Control.Monad.Extra (whenJustM) import "contra-tracer" Control.Tracer (stdoutTracer, traceWith) import Data.Word (Word32) import qualified Data.Bimap as BM -import Data.Foldable (traverse_) +import Data.Bimap (Bimap) +import Data.Foldable (for_, traverse_) import Data.Functor ((<&>), void) import Data.List.Extra (dropPrefix, dropSuffix, replace) import qualified Data.Map.Strict as Map @@ -167,16 +171,17 @@ askNodeName :: TracerEnv -> NodeId -> IO NodeName -askNodeName TracerEnv{teConnectedNodesNames, teDPRequestors, teCurrentDPLock} = - askNodeNameRaw teConnectedNodesNames teDPRequestors teCurrentDPLock +askNodeName TracerEnv{teTracer, teConnectedNodesNames, teDPRequestors, teCurrentDPLock} = + askNodeNameRaw teTracer teConnectedNodesNames teDPRequestors teCurrentDPLock askNodeNameRaw - :: ConnectedNodesNames + :: Trace IO TracerTrace + -> ConnectedNodesNames -> DataPointRequestors -> Lock -> NodeId -> IO NodeName -askNodeNameRaw connectedNodesNames dpRequestors currentDPLock nodeId@(NodeId anId) = do +askNodeNameRaw tracer connectedNodesNames dpRequestors currentDPLock nodeId@(NodeId anId) = do nodesNames <- readTVarIO connectedNodesNames case BM.lookup nodeId nodesNames of Just nodeName -> return nodeName @@ -186,8 +191,32 @@ askNodeNameRaw connectedNodesNames dpRequestors currentDPLock nodeId@(NodeId anI askDataPoint dpRequestors currentDPLock nodeId "NodeInfo" >>= \case Nothing -> return anId Just NodeInfo{niName} -> return $ if T.null niName then anId else niName - -- Store it in for the future using. - atomically . modifyTVar' connectedNodesNames $ BM.insert nodeId nodeName + + -- Overlapping node names are considered a misconfiguration. + -- However using the unique node ID as a fallback still ensures no + -- trace messages or metrics get lost. + maybePair <- atomically do + stateTVar connectedNodesNames \oldBimap -> + let + maybePair :: Maybe (NodeId, T.Text) + maybePair + | BM.member nodeId oldBimap + = Nothing + | BM.memberR nodeName oldBimap + = Just (nodeId, anId) + | otherwise + = Just (nodeId, nodeName) + + newBimap :: Bimap NodeId NodeName + newBimap = maybe oldBimap (\(k, v) -> BM.insert k v oldBimap) maybePair + + in (maybePair, newBimap) + + for_ @Maybe maybePair \pair -> + Tracer.traceWith tracer TracerAddNewNodeIdMapping + { ttBimapping = pair + } + return nodeName askNodeId diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs b/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs index f55d0a0ded4..a55b8eb08a1 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs @@ -51,8 +51,11 @@ launchAcceptorsSimple mode localSock dpName = do #endif currentLogLock <- newLock currentDPLock <- newLock + + tr <- mkTracerTracer $ SeverityF $ Just Warning + #if RTVIEW - eventsQueues <- initEventsQueues Nothing connectedNodesNames dpRequestors currentDPLock + eventsQueues <- initEventsQueues tr Nothing connectedNodesNames dpRequestors currentDPLock chainHistory <- initBlockchainHistory resourcesHistory <- initResourcesHistory @@ -61,8 +64,6 @@ launchAcceptorsSimple mode localSock dpName = do rtViewPageOpened <- newTVarIO False #endif - tr <- mkTracerTracer $ SeverityF $ Just Warning - registry <- newRegistry let tracerEnv :: TracerEnv 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-new-tracing.json b/configuration/cardano/mainnet-config-new-tracing.json index ee731016f3b..86a3c1fa7e7 100644 --- a/configuration/cardano/mainnet-config-new-tracing.json +++ b/configuration/cardano/mainnet-config-new-tracing.json @@ -18,11 +18,14 @@ "TurnOnLogging": true, "TurnOnLogMetrics": true, "UseTraceDispatcher": true, - "TraceOptionForwarder": null, - "TraceOptionMetricsPrefix": null, - "TraceOptionNodeName": null, - "TraceOptionPeerFrequency": 3000, - "TraceOptionResourceFrequency": 5000, + "TraceOptionMetricsPrefix": "cardano.node.metrics.", + "TraceOptionNodeName": "mainnetsingle", + "TraceOptionPeerFrequency": 2000, + "TraceOptionResourceFrequency": 1000, + "TraceOptionForwarder": { + "connQueueSize": 64, + "disconnQueueSize": 128 + }, "TraceOptions": { "": { "backends": [ @@ -42,7 +45,7 @@ "severity": "Silence" }, "ChainSync.Client": { - "severity": "Info" + "severity": "Warning" }, "Net.ConnectionManager.Remote": { "severity": "Info" @@ -74,17 +77,20 @@ "Mempool": { "severity": "Info" }, - "Mempool.Synced": { - "severity": "Silence" - }, "Net.Mux.Remote": { "severity": "Info" }, + "Net.InboundGovernor": { + "severity": "Warning" + }, "Net.PeerSelection": { - "severity": "Info" + "severity": "Silence" + }, + "Net.ConnectionManager.Remote.ConnectionManagerCounters": { + "severity": "Silence" }, "Resources": { - "severity": "Info" + "severity": "Silence" }, "ChainDB.AddBlockEvent.AddedBlockToQueue": { "maxFrequency": 2.0 @@ -98,9 +104,6 @@ "ChainDB.CopyToImmutableDBEvent.CopiedBlockToImmutableDB": { "maxFrequency": 2.0 }, - "ChainSync.Client.DownloadedHeader": { - "maxFrequency": 2.0 - }, "BlockFetch.Client.CompletedBlockFetch": { "maxFrequency": 2.0 } diff --git a/configuration/cardano/mainnet-config.yaml b/configuration/cardano/mainnet-config.yaml index a0f289896b6..1b40d514dc1 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 ##### diff --git a/configuration/cardano/shelley_qa-config.json b/configuration/cardano/shelley_qa-config.json index 853c6a48dc3..5f9db54810b 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": 40, "TargetNumberOfKnownPeers": 150, diff --git a/flake.lock b/flake.lock index eb6ac3d3599..030b6061b50 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1735999756, - "narHash": "sha256-fJeEZoyPrHi4ylsCm4CXypicNf2mfPbtvUfJuFcOllM=", + "lastModified": 1737030073, + "narHash": "sha256-Mdf9GfcJG2ehJM4yFkZKjTnOWCbutjAe7s+Z27fusA8=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "db6a4bdb6b83af17711a23e45266ab031894d788", + "rev": "1013daa305ed2a6e5f50edf8141d4edce94c06bc", "type": "github" }, "original": { @@ -526,11 +526,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1729039425, - "narHash": "sha256-sIglYcw8Dacj4n0bRlUWo+NLkDMcVi6vtmKvUyG+ZrQ=", + "lastModified": 1736987292, + "narHash": "sha256-ZK4gWwsTWIP6j+SIHy7f2BLPcs8Q1yO8bP18thkIHLQ=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "6dc43e5e01f113ce151056a8f94bce7bb2f13eb9", + "rev": "28b6ddfbfad7274f33ad99939e19afb29ee5adf6", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 0d63226bc9f..5b253a234c1 100644 --- a/flake.nix +++ b/flake.nix @@ -89,6 +89,11 @@ inherit (iohkNix.lib) prefixNamesWith; removeRecurse = lib.filterAttrsRecursive (n: _: n != "recurseForDerivations"); + macOS-security = pkgs: + # make `/usr/bin/security` available in `PATH`, which is needed for stack + # on darwin which calls this binary to find certificates + pkgs.writeScriptBin "security" ''exec /usr/bin/security "$@"''; + supportedSystems = import ./nix/supported-systems.nix; defaultSystem = head supportedSystems; customConfig = recursiveUpdate @@ -145,6 +150,9 @@ inherit (pkgs.stdenv) hostPlatform; project = pkgs.cardanoNodeProject; + macOS-security = + utils.writeScriptBin "security" ''exec /usr/bin/security "$@"''; + # This is used by `nix develop .` to open a devShell devShells = let @@ -401,6 +409,7 @@ inherit (final) haskell-nix; inherit (std) incl; inherit CHaP; + macOS-security = macOS-security (final.pkgs); }).appendModule [ customConfig.haskellNix ]; diff --git a/nix/haskell.nix b/nix/haskell.nix index 71ee8f37b40..e9aca8fe2dc 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -4,6 +4,7 @@ { haskell-nix , incl , CHaP +, macOS-security }: let @@ -127,6 +128,7 @@ let packages.cardano-protocol-tpraos.components.library.doHaddock = false; packages.ouroboros-consensus-cardano.components.library.doHaddock = false; packages.ouroboros-consensus.components.library.doHaddock = false; + packages.ouroboros-network.components.library.doHaddock = false; # Currently broken packages.plutus-ledger-api.components.library.doHaddock = false; }) ({ lib, pkgs, ...}: lib.mkIf (pkgs.stdenv.hostPlatform.isWindows) { @@ -281,7 +283,11 @@ let unset TMPDIR export TMPDIR=$(mktemp -d) export TMP=$TMPDIR - ''; + '' + (if pkgs.stdenv.hostPlatform.isDarwin + then '' + export PATH=${macOS-security}/bin:$PATH + '' + else ''''); packages.cardano-testnet.components.tests.cardano-testnet-golden.preCheck = let # This define files included in the directory that will be passed to `H.getProjectBase` for this test: diff --git a/nix/pkgs.nix b/nix/pkgs.nix index 95105eac31f..63dd1685d28 100644 --- a/nix/pkgs.nix +++ b/nix/pkgs.nix @@ -44,12 +44,12 @@ in with final; ghc927 = "3.5"; ghc928 = "3.5"; }.${config.compiler-nix-name} or "3.6.1"; - index-state = "2023-08-05T00:00:00Z"; + index-state = "2024-12-24T12:56:48Z"; }); ghcid = haskell-nix.tool compiler-nix-name "ghcid" { version = "0.8.7"; - index-state = "2023-08-05T00:00:00Z"; + index-state = "2024-12-24T12:56:48Z"; }; # The ghc-hls point release compatibility table is documented at @@ -71,7 +71,7 @@ in with final; haskellBuildUtils = prev.haskellBuildUtils.override { inherit compiler-nix-name; - index-state = "2023-08-05T00:00:00Z"; + index-state = "2024-12-24T12:56:48Z"; }; profiteur = haskell-nix.tool compiler-nix-name "profiteur" { 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..b1367281f9a 100644 --- a/trace-dispatcher/src/Cardano/Logging/Forwarding.hs +++ b/trace-dispatcher/src/Cardano/Logging/Forwarding.hs @@ -12,17 +12,19 @@ module Cardano.Logging.Forwarding ( initForwarding + , initForwardingDelayed ) where 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 +33,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 @@ -63,20 +66,35 @@ initForwarding :: forall m. (MonadIO m) -> Maybe EKG.Store -> Maybe (FilePath, ForwarderMode) -> m (ForwardSink TraceObject, DataPointStore) -initForwarding iomgr config magic ekgStore tracerSocketMode = liftIO $ do +initForwarding iomgr config magic ekgStore tracerSocketMode = do + (a, b, kickoffForwarder) <- initForwardingDelayed iomgr config magic ekgStore tracerSocketMode + liftIO kickoffForwarder + pure (a, b) + +-- We allow for delayed initialization of the forwarding connection by +-- returning an IO action to do so. +initForwardingDelayed :: forall m. (MonadIO m) + => IOManager + -> TraceOptionForwarder + -> NetworkMagic + -> Maybe EKG.Store + -> Maybe (FilePath, ForwarderMode) + -> m (ForwardSink TraceObject, DataPointStore, IO ()) +initForwardingDelayed iomgr config magic ekgStore tracerSocketMode = liftIO $ do forwardSink <- initForwardSink tfConfig handleOverflow dpStore <- initDataPointStore - launchForwarders - iomgr - magic - ekgConfig - tfConfig - dpfConfig - ekgStore - forwardSink - dpStore - tracerSocketMode - pure (forwardSink, dpStore) + let + kickoffForwarder = launchForwarders + iomgr + magic + ekgConfig + tfConfig + dpfConfig + ekgStore + forwardSink + dpStore + tracerSocketMode + pure (forwardSink, dpStore, kickoffForwarder) where p = maybe "" fst tracerSocketMode connSize = tofConnQueueSize config @@ -196,15 +214,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 +230,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 +306,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/FrequencyLimiter.hs b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs index 9a9a4afa8b9..92ba20dddf1 100644 --- a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs +++ b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs @@ -23,6 +23,9 @@ budgetLimit = 30.0 reminderPeriod :: Double reminderPeriod = 10.0 +data MaybeTuple' a b = Nothing' | Just' !a !b + deriving Show + data LimiterSpec = LimiterSpec { lsNs :: [Text] , lsName :: Text @@ -37,7 +40,7 @@ data FrequencyRec a = FrequencyRec { -- and stop limiting. When messages arrive in shorter frequency then -- by the given thresholdFrequency budget is earned, and if they -- arrive in a longer period budget is spend. - , frActive :: Maybe (Int, Double) + , frActive :: !(MaybeTuple' Int Double) -- ^ Just is active and carries the number -- of suppressed messages and the time of last send message } deriving (Show) @@ -81,7 +84,7 @@ limitFrequency thresholdFrequency limiterName ltracer vtracer = do timeNow <- systemTimeToSeconds <$> liftIO getSystemTime foldTraceM (checkLimiting (1.0 / thresholdFrequency)) - (FrequencyRec Nothing timeNow 0.0 0.0 Nothing) + (FrequencyRec Nothing timeNow 0.0 0.0 Nothing') (Trace $ T.contramap unfoldTrace (unpackTrace (filterTraceMaybe vtracer))) where checkLimiting :: @@ -110,7 +113,7 @@ limitFrequency thresholdFrequency limiterName ltracer vtracer = do let newBudget = min budgetLimit (max (-budgetLimit) (normaSpendReward + frBudget)) case frActive of - Nothing -> -- limiter not active + Nothing' -> -- limiter not active if normaSpendReward + frBudget >= budgetLimit then do -- start limiting traceWith @@ -121,7 +124,7 @@ limitFrequency thresholdFrequency limiterName ltracer vtracer = do , frLastTime = timeNow , frLastRem = timeNow , frBudget = newBudget - , frActive = Just (0, timeNow) + , frActive = Just' 0 timeNow } else -- continue without limiting pure fs { frMessage = Just message @@ -129,7 +132,7 @@ limitFrequency thresholdFrequency limiterName ltracer vtracer = do , frLastRem = 0.0 , frBudget = newBudget } - Just (nSuppressed, lastTimeSend) -> -- is active + Just' nSuppressed lastTimeSend -> -- is active if normaSpendReward + frBudget <= (- budgetLimit) then do -- stop limiting traceWith @@ -139,7 +142,7 @@ limitFrequency thresholdFrequency limiterName ltracer vtracer = do pure fs { frMessage = Just message , frLastTime = timeNow , frBudget = newBudget - , frActive = Nothing + , frActive = Nothing' } else let lastPeriod = timeNow - lastTimeSend @@ -160,14 +163,14 @@ limitFrequency thresholdFrequency limiterName ltracer vtracer = do , frLastTime = timeNow , frLastRem = newFrLastRem , frBudget = newBudget - , frActive = Just (nSuppressed, timeNow) + , frActive = Just' nSuppressed timeNow } else -- suppress pure fs { frMessage = Nothing , frLastTime = timeNow , frLastRem = newFrLastRem , frBudget = newBudget - , frActive = Just (nSuppressed + 1, lastTimeSend) + , frActive = Just' (nSuppressed + 1) lastTimeSend } unfoldTrace :: (LoggingContext, Either TraceControl (Folding a (FrequencyRec a))) 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/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs index e2c21afe5ea..086613cb073 100644 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -445,20 +445,35 @@ data TraceOptionForwarder = TraceOptionForwarder { , tofVerbosity :: Verbosity } deriving (Eq, Generic, Ord, Show, AE.ToJSON) +-- A word regarding queue sizes: +-- In case of a missing forwarding service consumer, traces messages will be +-- buffered. This mitigates short forwarding interruptions, or delays at startup time. +-- +-- The queue capacity should thus correlate to the expected log lines per second given +-- a particular tracing configuration - to avoid unnecessarily increasing memory footprint. +-- +-- The default values here are chosen to accomodate verbose tracing output +-- (i.e., buffering 1min worth of trace data given ~32 messages per second). A config +-- that results in less than 5 msgs per second should also provide TraceOptionForwarder +-- queue size values considerably lower. The `disconnQueueSize` is the hard limit in that case. +-- +-- The queue sizes tie in with the max number of trace objects cardano-tracer requests periodically, +-- the default for that being 100. Here, the basic queue can hold enough traces for 10 subsequent polls +-- by cardano-tracer. instance AE.FromJSON TraceOptionForwarder where parseJSON (AE.Object obj) = TraceOptionForwarder - <$> obj AE..:? "connQueueSize" AE..!= 2000 - <*> obj AE..:? "disconnQueueSize" AE..!= 200000 + <$> obj AE..:? "connQueueSize" AE..!= 1024 + <*> obj AE..:? "disconnQueueSize" AE..!= 2048 <*> obj AE..:? "verbosity" AE..!= Minimum parseJSON _ = mempty defaultForwarder :: TraceOptionForwarder defaultForwarder = TraceOptionForwarder { - tofConnQueueSize = 2000 - , tofDisconnQueueSize = 200000 - , tofVerbosity = Minimum + tofConnQueueSize = 1024 + , tofDisconnQueueSize = 2048 + , tofVerbosity = Minimum } instance AE.FromJSON ForwarderMode where diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal index 09f155b25c6..dfdab693e00 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 + , ekg-forward >= 0.8 , hostname , network + , network-mux , optparse-applicative-fork - , ouroboros-network ^>= 0.17 + , ouroboros-network ^>= 0.19 , 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..d0cb538e964 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} -- | The type of the 'DataPoint' forwarding/accepting protocol. @@ -14,16 +15,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 +63,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 +115,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..b003cac8a7a 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs @@ -1,15 +1,19 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} 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 +34,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..224996e8d29 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs @@ -1,11 +1,13 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} -- | The type of the trace forwarding/accepting protocol. @@ -13,23 +15,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 +51,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 +87,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 +111,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 +176,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..d294e5aaf3b 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.15 , serialise , stm , text - , typed-protocols ^>= 0.1 + , typed-protocols ^>= 0.3 , typed-protocols-cborg test-suite test