diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index 6454488..887cd8d 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -1,4 +1,4 @@ -# Stylish-haskell configuration file used for the dmq-node +# Stylish-haskell configuration file used for the network layer # It's based on default config provided by `stylish-haskell --defaults` but # has some changes ================================== @@ -288,3 +288,4 @@ language_extensions: - TypeFamilies - ViewPatterns - ExplicitNamespaces + diff --git a/cabal.project b/cabal.project index 5e1d695..2ccb4ad 100644 --- a/cabal.project +++ b/cabal.project @@ -15,10 +15,10 @@ repository cardano-haskell-packages -- repeat the index-state for hackage to work around haskell.nix parsing limitation index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2025-11-10T01:36:00Z + , hackage.haskell.org 2026-02-17T10:15:41Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2026-01-09T12:04:47Z + , cardano-haskell-packages 2026-02-17T21:19:19Z packages: ./dmq-node @@ -36,18 +36,58 @@ if(os(windows)) -- kes-agent is not yet in CHaP, so we pull it from its GitHub repo source-repository-package type: git - location: https://github.com/crocodile-dentist/kes-agent - tag: c0ef04dde5582a28415ff7c8c1bb197adeec6fc8 - --sha256: sha256-slF7zuBy2DKWKlQfhBPW5FDRhueWrFcJkrHW4jEEELs= + location: https://github.com/input-output-hk/kes-agent + tag: 84c98f369d58e86cf7a339ccce583252d4cb5773 + --sha256: sha256-0RsKmpXcJfO4bFos5Mx71lUye3bo7g6lc+gXCaKzxJs= subdir: kes-agent kes-agent-crypto +-- Ledger main past the releases for node-cardano-10.6 +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger + tag: bd2c3fc558c8b053b03f25a84fc02e26dd17d927 + --sha256: sha256-JCzOtN0/eQob9IneXjihwxDgWZlSZ2ZdIkz2qBPhtU8= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/conway/impl + eras/dijkstra/impl + eras/mary/impl + eras/shelley/impl + eras/shelley/test-suite + eras/shelley-ma/test-suite + libs/cardano-ledger-api + libs/cardano-ledger-core + libs/cardano-ledger-binary + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/cardano-data + libs/vector-map + eras/byron/chain/executable-spec + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/byron/crypto + +-- Plutus main past the 1.58 release +source-repository-package + type: git + location: https://github.com/IntersectMBO/plutus + tag: 9b47adbd2e0cf9b4749e53f5138b3817eaa5f0b4 + --sha256: sha256-wqriBVjkC1mW/Mp+FButFNBRClync9cDwZtgG+a6lb0= + subdir: + plutus-core + plutus-ledger-api + source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 454e2491a23d14161c159d815bd26c545455c9ef - --sha256: sha256-ODoM1dCyKM8MiMherH1xxcJtzoYdqbhDGkwzFB6SKeM= + tag: 49351452ea456b6242fa50e5ba3724ea6b66117d + --sha256: sha256-4ONSJnD5x89HAfhUk/Kt6/CePc1OL2i15J7d4wpsQ10= subdir: ouroboros-consensus-cardano ouroboros-consensus-diffusion @@ -58,9 +98,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - -- from coot/dmq-related-changes - tag: 625296c92363b8c5e77cddee40de4525421d2660 - --sha256: sha256-WRbKqNimAsYtgj/r3SJ0IT6z7+Q3XZf3p89BM9w6bF8= + tag: 5be7d7897145fd432867c4dd095e0d62e53b3be9 + --sha256: sha256-AeAvjWx0SbnFeamB/pNO19gTbSyRjFRn7xPOsLHnq7s= subdir: acts-generic cardano-diffusion @@ -70,3 +109,6 @@ source-repository-package if impl(ghc >= 9.12.0) allow-newer: *:time, *:nothunks, + +-- rejecting: cardano-crypto-class-2.3.1.0 (conflict: cardano-crypto-tests => cardano-crypto-class>=2.2.2 && <2.2.4) +-- allow-newer: cardano-crypto-tests:cardano-crypto-class diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index 714d7b7..784173d 100644 --- a/dmq-node/app/Main.hs +++ b/dmq-node/app/Main.hs @@ -10,8 +10,8 @@ module Main where -import Control.Concurrent.Class.MonadSTM.Strict import Control.Concurrent.Class.MonadMVar +import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (void, when) import Control.Monad.Class.MonadThrow import Control.Tracer (Tracer (..), nullTracer, traceWith) @@ -19,8 +19,8 @@ import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Act import Data.Aeson (ToJSON) import Data.ByteString.Lazy qualified as BSL -import Data.Functor.Contravariant ((>$<)) import Data.Foldable (traverse_) +import Data.Functor.Contravariant ((>$<)) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (maybeToList) import Data.Text qualified as Text @@ -29,8 +29,8 @@ import Data.Version (showVersion) import Data.Void (Void) import Options.Applicative import System.Exit (exitSuccess) -import System.Random (newStdGen, split) import System.IOManager (withIOManager) +import System.Random qualified as Random import Cardano.Git.Rev (gitRev) import Cardano.KESAgent.Protocols.StandardCrypto (StandardCrypto) @@ -49,7 +49,6 @@ import DMQ.Protocol.SigSubmission.Type (Sig (..)) import DMQ.Tracer import DMQ.Diffusion.PeerSelection (policy) -import DMQ.NodeToClient.LocalStateQueryClient import DMQ.Protocol.SigSubmission.Validate import Ouroboros.Network.Diffusion qualified as Diffusion import Ouroboros.Network.PeerSelection.LedgerPeers.Type @@ -86,9 +85,7 @@ runDMQ commandLineConfig = do dmqcHandshakeTracer = I handshakeTracer, dmqcValidationTracer = I validationTracer, dmqcLocalHandshakeTracer = I localHandshakeTracer, - dmqcCardanoNodeSocket = I snocketPath, - dmqcVersion = I version, - dmqcLocalStateQueryTracer = I localStateQueryTracer + dmqcVersion = I version } = config' <> commandLineConfig `act` defaultConfiguration @@ -121,25 +118,18 @@ runDMQ commandLineConfig = do nt <- readTopologyFileOrError topologyFile traceWith tracer (WithEventType "NetworkTopology" nt) - stdGen <- newStdGen - let (psRng, policyRng) = split stdGen + stdGen <- Random.newStdGen + let (psRng, policyRng) = Random.splitGen stdGen policyRngVar <- newTVarIO policyRng -- TODO: this might not work, since `ouroboros-network` creates its own IO Completion Port. withIOManager \iocp -> do - let localSnocket' = localSnocket iocp - mkStakePoolMonitor = connectToCardanoNode - (if localStateQueryTracer - then WithEventType "LocalStateQuery" >$< tracer - else nullTracer) - localSnocket' - snocketPath - withNodeKernel @StandardCrypto + (localSnocket iocp) + makeLocalBearer tracer dmqConfig - psRng - mkStakePoolMonitor $ \nodeKernel -> do + psRng $ \nodeKernel -> do dmqDiffusionConfiguration <- mkDiffusionConfiguration dmqConfig nt nodeKernel.stakePools.ledgerBigPeersVar diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index 0d1e735..2f82787 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -63,6 +63,7 @@ library DMQ.Diffusion.Applications DMQ.Diffusion.Arguments DMQ.Diffusion.NodeKernel + DMQ.Diffusion.NodeKernel.Types DMQ.Diffusion.PeerSelection DMQ.Handlers.TopLevel DMQ.NodeToClient @@ -97,9 +98,11 @@ library cardano-crypto-class, cardano-crypto-wrapper, cardano-diffusion, + cardano-ledger-api, cardano-ledger-byron, cardano-ledger-core, cardano-ledger-shelley, + cardano-protocol-tpraos, cardano-slotting, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.8, @@ -110,21 +113,21 @@ library hashable >=1.0 && <1.6, io-classes:{io-classes, si-timers, strict-mvar, strict-stm} ^>=1.8.0.1, iproute ^>=1.7.15, - kes-agent-crypto ^>=0.1, + kes-agent-crypto ^>=1.0, mtl, network ^>=3.2.7, - network-mux ^>=0.9.1, + network-mux ^>=0.10, optparse-applicative >=0.18 && <0.20, ouroboros-consensus, ouroboros-consensus-cardano, ouroboros-consensus-diffusion, - ouroboros-network:{ouroboros-network, api, framework, orphan-instances, protocols} ^>=0.23, - random ^>=1.2, + ouroboros-network:{ouroboros-network, api, framework, orphan-instances, protocols} ^>=0.24, + random ^>=1.3, singletons, text >=1.2.4 && <2.2, time >=1.12 && <1.15, transformers, - typed-protocols:{typed-protocols, cborg} ^>=1.1, + typed-protocols:{typed-protocols, cborg} ^>=1.2, hs-source-dirs: src default-language: Haskell2010 @@ -181,17 +184,17 @@ test-suite dmq-tests QuickCheck, base >=4.14 && <4.23, bytestring, - cardano-crypto-class, - cardano-crypto-tests, + cardano-crypto-class:{cardano-crypto-class, testlib}, + cardano-ledger-api, cardano-ledger-core, cborg, containers, contra-tracer, + deepseq, dmq-node, io-classes:{io-classes, si-timers}, io-sim, kes-agent-crypto, - ouroboros-consensus-cardano, ouroboros-network:{api, framework, protocols, protocols-tests-lib, tests-lib}, quickcheck-instances, serialise, diff --git a/dmq-node/src/DMQ/Configuration.hs b/dmq-node/src/DMQ/Configuration.hs index fc0b1ec..4010cc0 100644 --- a/dmq-node/src/DMQ/Configuration.hs +++ b/dmq-node/src/DMQ/Configuration.hs @@ -33,7 +33,7 @@ module DMQ.Configuration ) where import Cardano.Chain.Genesis (mainnetProtocolMagicId) -import Cardano.Crypto.ProtocolMagic (ProtocolMagicId(..)) +import Cardano.Crypto.ProtocolMagic (ProtocolMagicId (..)) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI (DiffTime) @@ -86,106 +86,106 @@ import DMQ.Configuration.Topology (NoExtraConfig (..), NoExtraFlags (..)) data Configuration' f = Configuration { -- | Path from which the `Configuration` is read. - dmqcConfigFile :: f FilePath, + dmqcConfigFile :: f FilePath, -- | Network magic for the DMQ network - dmqcNetworkMagic :: f NetworkMagic, + dmqcNetworkMagic :: f NetworkMagic, -- | Network magic for local connections to a cardano-node - dmqcCardanoNetworkMagic :: f NetworkMagic, + dmqcCardanoNetworkMagic :: f NetworkMagic, -- | IPv4 address to bind to for `node-to-node` communication. - dmqcIPv4 :: f (Maybe IPv4), + dmqcIPv4 :: f (Maybe IPv4), -- | IPv6 address to bind to for `node-to-node` communication. - dmqcIPv6 :: f (Maybe IPv6), + dmqcIPv6 :: f (Maybe IPv6), -- | Port number for `node-to-node` DMQ communication. - dmqcPortNumber :: f PortNumber, + dmqcPortNumber :: f PortNumber, -- | Local socket address for `node-to-client` DMQ communication. - dmqcLocalAddress :: f LocalAddress, + dmqcLocalAddress :: f LocalAddress, -- | Topology file path. - dmqcTopologyFile :: f FilePath, + dmqcTopologyFile :: f FilePath, -- | Path to the `cardano-node` socket. - dmqcCardanoNodeSocket :: f FilePath, + dmqcCardanoNodeSocket :: f FilePath, - dmqcAcceptedConnectionsLimit :: f AcceptedConnectionsLimit, + dmqcAcceptedConnectionsLimit :: f AcceptedConnectionsLimit, -- | Diffusion mode for `node-to-node` communication. - dmqcDiffusionMode :: f DiffusionMode, + dmqcDiffusionMode :: f DiffusionMode, -- | Node-to-node inbound connection idle timeout. - dmqcProtocolIdleTimeout :: f DiffTime, + dmqcProtocolIdleTimeout :: f DiffTime, -- | Churn interval for peer selection. - dmqcChurnInterval :: f DiffTime, + dmqcChurnInterval :: f DiffTime, -- | Peer sharing setting. - dmqcPeerSharing :: f PeerSharing, + dmqcPeerSharing :: f PeerSharing, + -- | Ledger peers are hidden behind a flag. + dmqcLedgerPeers :: f Bool, -- -- Peer Selection Targets -- - dmqcTargetOfRootPeers :: f Int, - dmqcTargetOfKnownPeers :: f Int, - dmqcTargetOfEstablishedPeers :: f Int, - dmqcTargetOfActivePeers :: f Int, - dmqcTargetOfKnownBigLedgerPeers :: f Int, - dmqcTargetOfEstablishedBigLedgerPeers :: f Int, - dmqcTargetOfActiveBigLedgerPeers :: f Int, + dmqcTargetOfRootPeers :: f Int, + dmqcTargetOfKnownPeers :: f Int, + dmqcTargetOfEstablishedPeers :: f Int, + dmqcTargetOfActivePeers :: f Int, + dmqcTargetOfKnownBigLedgerPeers :: f Int, + dmqcTargetOfEstablishedBigLedgerPeers :: f Int, + dmqcTargetOfActiveBigLedgerPeers :: f Int, -- -- Tracers & logging -- - dmqcPrettyLog :: f Bool, - - dmqcMuxTracer :: f Bool, - dmqcChannelTracer :: f Bool, - dmqcBearerTracer :: f Bool, - dmqcHandshakeTracer :: f Bool, - dmqcLocalMuxTracer :: f Bool, - dmqcLocalChannelTracer :: f Bool, - dmqcLocalBearerTracer :: f Bool, - dmqcLocalHandshakeTracer :: f Bool, - dmqcDiffusionTracer :: f Bool, - dmqcTraceLocalRootPeersTracer :: f Bool, - dmqcTracePublicRootPeersTracer :: f Bool, - dmqcTraceLedgerPeersTracer :: f Bool, - dmqcTracePeerSelectionTracer :: f Bool, - dmqcTraceChurnCounters :: f Bool, - dmqcDebugPeerSelectionInitiatorTracer :: f Bool, - dmqcDebugPeerSelectionInitiatorResponderTracer :: f Bool, - dmqcTracePeerSelectionCounters :: f Bool, - dmqcPeerSelectionActionsTracer :: f Bool, - dmqcConnectionManagerTracer :: f Bool, - dmqcConnectionManagerTransitionTracer :: f Bool, - dmqcServerTracer :: f Bool, - dmqcInboundGovernorTracer :: f Bool, - dmqcInboundGovernorTransitionTracer :: f Bool, - dmqcLocalConnectionManagerTracer :: f Bool, - dmqcLocalServerTracer :: f Bool, - dmqcLocalInboundGovernorTracer :: f Bool, - dmqcDnsTracer :: f Bool, - dmqcValidationTracer :: f Bool, + dmqcPrettyLog :: f Bool, + + dmqcMuxTracer :: f Bool, + dmqcChannelTracer :: f Bool, + dmqcBearerTracer :: f Bool, + dmqcHandshakeTracer :: f Bool, + dmqcLocalMuxTracer :: f Bool, + dmqcLocalChannelTracer :: f Bool, + dmqcLocalBearerTracer :: f Bool, + dmqcLocalHandshakeTracer :: f Bool, + dmqcDiffusionTracer :: f Bool, + dmqcTraceLocalRootPeersTracer :: f Bool, + dmqcTracePublicRootPeersTracer :: f Bool, + dmqcTraceLedgerPeersTracer :: f Bool, + dmqcTracePeerSelectionTracer :: f Bool, + dmqcDebugPeerSelectionTracer :: f Bool, + dmqcTracePeerSelectionCounters :: f Bool, + dmqcPeerSelectionActionsTracer :: f Bool, + dmqcConnectionManagerTracer :: f Bool, + dmqcConnectionManagerTransitionTracer :: f Bool, + dmqcServerTracer :: f Bool, + dmqcInboundGovernorTracer :: f Bool, + dmqcInboundGovernorTransitionTracer :: f Bool, + dmqcLocalConnectionManagerTracer :: f Bool, + dmqcLocalServerTracer :: f Bool, + dmqcLocalInboundGovernorTracer :: f Bool, + dmqcDnsTracer :: f Bool, + dmqcValidationTracer :: f Bool, -- low level verbose traces which trace protocol messages -- TODO: pref - dmqcSigSubmissionClientProtocolTracer :: f Bool, - dmqcSigSubmissionServerProtocolTracer :: f Bool, - dmqcKeepAliveClientProtocolTracer :: f Bool, - dmqcKeepAliveServerProtocolTracer :: f Bool, - dmqcPeerSharingClientProtocolTracer :: f Bool, - dmqcPeerSharingServerProtocolTracer :: f Bool, - dmqcLocalMsgSubmissionServerProtocolTracer :: f Bool, - dmqcLocalMsgNotificationServerProtocolTracer :: f Bool, + dmqcSigSubmissionClientProtocolTracer :: f Bool, + dmqcSigSubmissionServerProtocolTracer :: f Bool, + dmqcKeepAliveClientProtocolTracer :: f Bool, + dmqcKeepAliveServerProtocolTracer :: f Bool, + dmqcPeerSharingClientProtocolTracer :: f Bool, + dmqcPeerSharingServerProtocolTracer :: f Bool, + dmqcLocalMsgSubmissionServerProtocolTracer :: f Bool, + dmqcLocalMsgNotificationServerProtocolTracer :: f Bool, -- -- Application tracers -- - dmqcSigSubmissionLogicTracer :: f Bool, - dmqcSigSubmissionOutboundTracer :: f Bool, - dmqcSigSubmissionInboundTracer :: f Bool, - dmqcLocalMsgSubmissionServerTracer :: f Bool, - dmqcLocalMsgNotificationServerTracer :: f Bool, - dmqcLocalStateQueryTracer :: f Bool, + dmqcSigSubmissionLogicTracer :: f Bool, + dmqcSigSubmissionOutboundTracer :: f Bool, + dmqcSigSubmissionInboundTracer :: f Bool, + dmqcLocalMsgSubmissionServerTracer :: f Bool, + dmqcLocalMsgNotificationServerTracer :: f Bool, + dmqcLocalStateQueryTracer :: f Bool, -- | CLI only option to show version and exit. - dmqcVersion :: f Bool + dmqcVersion :: f Bool } deriving Generic @@ -261,6 +261,7 @@ defaultConfiguration = Configuration { dmqcProtocolIdleTimeout = I defaultProtocolIdleTimeout, dmqcChurnInterval = I defaultDeadlineChurnInterval, dmqcPeerSharing = I PeerSharingEnabled, + dmqcLedgerPeers = I False, dmqcPrettyLog = I False, dmqcMuxTracer = I True, dmqcChannelTracer = I False, @@ -275,9 +276,7 @@ defaultConfiguration = Configuration { dmqcTracePublicRootPeersTracer = I False, dmqcTraceLedgerPeersTracer = I False, dmqcTracePeerSelectionTracer = I True, - dmqcTraceChurnCounters = I True, - dmqcDebugPeerSelectionInitiatorTracer = I False, - dmqcDebugPeerSelectionInitiatorResponderTracer = I False, + dmqcDebugPeerSelectionTracer = I False, dmqcTracePeerSelectionCounters = I True, dmqcPeerSelectionActionsTracer = I False, dmqcConnectionManagerTracer = I True, @@ -341,6 +340,7 @@ instance FromJSON PartialConfig where dmqcNetworkMagic <- Last . fmap NetworkMagic <$> v .:? "NetworkMagic" dmqcCardanoNetworkMagic <- Last . fmap NetworkMagic <$> v .:? "CardanoNetworkMagic" dmqcDiffusionMode <- Last <$> v .:? "DiffusionMode" + dmqcLedgerPeers <- Last <$> v .:? "LedgerPeers" dmqcPeerSharing <- Last <$> v .:? "PeerSharing" dmqcCardanoNodeSocket <- Last <$> v .:? "CardanoNodeSocket" @@ -371,9 +371,7 @@ instance FromJSON PartialConfig where dmqcTracePublicRootPeersTracer <- Last <$> v .:? "PublicRootPeersTracer" dmqcTraceLedgerPeersTracer <- Last <$> v .:? "LedgerPeersTracer" dmqcTracePeerSelectionTracer <- Last <$> v .:? "PeerSelectionTracer" - dmqcTraceChurnCounters <- Last <$> v .:? "ChurnCounters" - dmqcDebugPeerSelectionInitiatorTracer <- Last <$> v .:? "DebugPeerSelectionInitiatorTracer" - dmqcDebugPeerSelectionInitiatorResponderTracer <- Last <$> v .:? "DebugPeerSelectionInitiatorResponderTracer" + dmqcDebugPeerSelectionTracer <- Last <$> v .:? "DebugPeerSelectionTracer" dmqcTracePeerSelectionCounters <- Last <$> v .:? "PeerSelectionCounters" dmqcPeerSelectionActionsTracer <- Last <$> v .:? "PeerSelectionActionsTracer" dmqcConnectionManagerTracer <- Last <$> v .:? "ConnectionManagerTracer" @@ -435,6 +433,7 @@ instance ToJSON Configuration where , "TargetOfActiveBigLedgerPeers" .= unI dmqcTargetOfActiveBigLedgerPeers , "ProtocolIdleTimeout" .= unI dmqcProtocolIdleTimeout , "ChurnInterval" .= unI dmqcChurnInterval + , "LedgerPeers" .= unI dmqcLedgerPeers , "PeerSharing" .= unI dmqcPeerSharing , "NetworkMagic" .= unNetworkMagic (unI dmqcNetworkMagic) , "CardanoNetworkMagic" .= unNetworkMagic (unI dmqcCardanoNetworkMagic) @@ -452,9 +451,7 @@ instance ToJSON Configuration where , "PublicRootPeersTracer" .= unI dmqcTracePublicRootPeersTracer , "LedgerPeersTracer" .= unI dmqcTraceLedgerPeersTracer , "PeerSelectionTracer" .= unI dmqcTracePeerSelectionTracer - , "ChurnCounters" .= unI dmqcTraceChurnCounters - , "DebugPeerSelectionInitiatorTracer" .= unI dmqcDebugPeerSelectionInitiatorTracer - , "DebugPeerSelectionInitiatorResponderTracer" .= unI dmqcDebugPeerSelectionInitiatorResponderTracer + , "DebugPeerSelectionTracer" .= unI dmqcDebugPeerSelectionTracer , "PeerSelectionCounters" .= unI dmqcTracePeerSelectionCounters , "PeerSelectionActionsTracer" .= unI dmqcPeerSelectionActionsTracer , "ConnectionManagerTracer" .= unI dmqcConnectionManagerTracer diff --git a/dmq-node/src/DMQ/Diffusion/Applications.hs b/dmq-node/src/DMQ/Diffusion/Applications.hs index 071f9eb..9ab677d 100644 --- a/dmq-node/src/DMQ/Diffusion/Applications.hs +++ b/dmq-node/src/DMQ/Diffusion/Applications.hs @@ -30,7 +30,7 @@ diffusionApplications -> PeerSelectionPolicy ntnAddr m -> Diffusion.Applications ntnAddr NodeToNodeVersion NodeToNodeVersionData ntcAddr NodeToClientVersion NodeToClientVersionData - m a + NoExtraFlags m a diffusionApplications NodeKernel { peerSharingRegistry diff --git a/dmq-node/src/DMQ/Diffusion/Arguments.hs b/dmq-node/src/DMQ/Diffusion/Arguments.hs index a00ea72..e2efb50 100644 --- a/dmq-node/src/DMQ/Diffusion/Arguments.hs +++ b/dmq-node/src/DMQ/Diffusion/Arguments.hs @@ -36,7 +36,8 @@ import Ouroboros.Network.PeerSelection.Churn (peerChurnGovernor) import Ouroboros.Network.PeerSelection.Governor.Types (ExtraGuardedDecisions (..), PeerSelectionGovernorArgs (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeersConsensusInterface (..), PoolStake, LedgerRelayAccessPoint) + (LedgerPeersConsensusInterface (..), LedgerRelayAccessPoint, + PoolStake) import Ouroboros.Network.PeerSelection.RelayAccessPoint (SRVPrefix) import Ouroboros.Network.PeerSelection.Types (nullPublicExtraPeersAPI) @@ -98,6 +99,7 @@ diffusionArguments handshakeNtNTracer , enableProgressMakingActions = const True , ledgerPeerSnapshotExtraStateChange = id } + , defaultExtraFlags = NoExtraFlags } , Diffusion.daPeerSelectionStateToExtraCounters = const NoExtraCounters , Diffusion.daToExtraPeers = const NoExtraPeers diff --git a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs index 2c7a484..b5f7427 100644 --- a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs +++ b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs @@ -1,112 +1,83 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} module DMQ.Diffusion.NodeKernel ( NodeKernel (..) , withNodeKernel , PoolValidationCtx (..) , StakePools (..) + , SomeLedgerPeerSnapshot , PoolId ) where +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadMVar import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI -import Control.Tracer (Tracer, nullTracer) +import Control.Tracer (Tracer (..), nullTracer) import Data.Aeson qualified as Aeson import Data.Function (on) import Data.Functor.Contravariant ((>$<)) import Data.Hashable -import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Proxy import Data.Sequence (Seq) import Data.Sequence qualified as Seq import Data.Set (Set) import Data.Set qualified as Set import Data.Time.Clock.POSIX (POSIXTime) import Data.Time.Clock.POSIX qualified as Time -import Data.Void (Void) -import Data.Word +import Data.Void (Void, absurd) import System.Random (StdGen) import System.Random qualified as Random -import Cardano.Ledger.Shelley.API qualified as Ledger -import Ouroboros.Consensus.Shelley.Ledger.Query qualified as LedgerQuery +import Network.Mux qualified as Mx -import Ouroboros.Network.BlockFetch (FetchClientRegistry, - newFetchClientRegistry) -import Ouroboros.Network.ConnectionId (ConnectionId (..)) -import Ouroboros.Network.Magic (NetworkMagic (..)) +import Cardano.Chain.Slotting (EpochSlots (..)) +import Cardano.Network.NodeToClient qualified as Cardano.NtoC +import Cardano.Protocol.Crypto qualified as Cardano (StandardCrypto) + +import Ouroboros.Consensus.Cardano.Node +import Ouroboros.Consensus.Network.NodeToClient +import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Network.BlockFetch (newFetchClientRegistry) +import Ouroboros.Network.Mux qualified as Mx import Ouroboros.Network.PeerSelection.Governor.Types (makePublicPeerSelectionStateVar) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot, - LedgerPeersKind (..)) -import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry, - newPeerSharingAPI, newPeerSharingRegistry, +import Ouroboros.Network.PeerSelection.LedgerPeers (SomeLedgerPeerSnapshot) +import Ouroboros.Network.PeerSharing (newPeerSharingAPI, newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME) +import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, + noTimeLimitsHandshake) +import Ouroboros.Network.Protocol.LocalStateQuery.Client +import Ouroboros.Network.Protocol.LocalStateQuery.Type +import Ouroboros.Network.Snocket (Snocket, localAddressFromPath) +import Ouroboros.Network.Socket (ConnectToArgs (..), + HandshakeCallbacks (HandshakeCallbacks), connectToNode) import Ouroboros.Network.TxSubmission.Inbound.V2 import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool (..), MempoolSeq (..), WithIndex (..)) import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool +import Cardano.Network.NodeToClient qualified as Cardano import DMQ.Configuration +import DMQ.Diffusion.NodeKernel.Types +import DMQ.NodeToClient.LocalStateQueryClient import DMQ.Protocol.SigSubmission.Type (Sig (sigExpiresAt, sigId), SigId) import DMQ.Tracer +import Ouroboros.Consensus.Cardano.Block (CardanoBlock) +import Ouroboros.Network.Handshake.Queryable (Queryable (..)) +import Ouroboros.Network.Protocol.Handshake (Acceptable (..)) -data NodeKernel crypto ntnAddr m = - NodeKernel { - -- | The fetch client registry, used for the keep alive clients. - fetchClientRegistry :: !(FetchClientRegistry (ConnectionId ntnAddr) () () m) - - -- | Read the current peer sharing registry, used for interacting with - -- the PeerSharing protocol - , peerSharingRegistry :: !(PeerSharingRegistry ntnAddr m) - , peerSharingAPI :: !(PeerSharingAPI ntnAddr StdGen m) - , mempool :: !(Mempool m SigId (Sig crypto)) - , sigChannelVar :: !(TxChannelsVar m ntnAddr SigId (Sig crypto)) - , sigMempoolSem :: !(TxMempoolSem m) - , sigSharedTxStateVar :: !(SharedTxStateVar m ntnAddr SigId (Sig crypto)) - , stakePools :: !(StakePools m) - , nextEpochVar :: !(StrictTVar m (Maybe UTCTime)) - } - --- | Cardano pool id's are hashes of the cold verification key --- -type PoolId = Ledger.KeyHash Ledger.StakePool - -data StakePools m = StakePools { - -- | contains map of cardano pool stake snapshot obtained - -- via local state query client - stakePoolsVar - :: !(StrictTVar m (Map PoolId LedgerQuery.StakeSnapshot)) - -- | Acquire and update validation context for signature validation - , withPoolValidationCtx - :: forall a. (PoolValidationCtx -> (a, PoolValidationCtx)) -> STM m a - -- | provides only those big peers which provide SRV endpoints - -- as otherwise those are cardano-nodes - , ledgerBigPeersVar - :: !(StrictTVar m (Maybe (LedgerPeerSnapshot BigLedgerPeers))) - -- | all ledger peers, restricted to srv endpoints - , ledgerPeersVar - :: !(StrictTMVar m (LedgerPeerSnapshot AllLedgerPeers)) - } - -data PoolValidationCtx = - PoolValidationCtx { - vctxEpoch :: !(Maybe UTCTime) - -- ^ UTC time of next epoch boundary for handling clock skew - , vctxStakeMap :: !(Map PoolId LedgerQuery.StakeSnapshot) - -- ^ for signature validation - , vctxOcertMap :: !(Map PoolId Word64) - -- ^ ocert counters to check monotonicity - } - deriving Show - newNodeKernel :: forall crypto ntnAddr m. ( MonadLabelledSTM m , MonadMVar m @@ -123,7 +94,7 @@ newNodeKernel rng = do mempool <- Mempool.empty sigChannelVar <- newTxChannelsVar sigMempoolSem <- newTxMempoolSem - let (rng', rng'') = Random.split rng + let (rng', rng'') = Random.splitGen rng sigSharedTxStateVar <- newSharedTxStateVar rng' (nextEpochVar, ocertCountersVar, stakePoolsVar, ledgerBigPeersVar, ledgerPeersVar) <- atomically $ (,,,,) <$> newTVar Nothing @@ -169,32 +140,44 @@ newNodeKernel rng = do withNodeKernel :: forall crypto ntnAddr m a. - ( MonadAsync m - , MonadFork m - , MonadDelay m - , MonadLabelledSTM m - , MonadMask m - , MonadMVar m - , MonadTime m + ( Alternative (STM m) + , MonadAsync m + , MonadEvaluate m + , MonadFork m + , MonadDelay m + , MonadLabelledSTM m + , MonadMask m + , MonadMVar m + , Mx.MonadReadBuffer m + , MonadST m + , MonadThrow (STM m) + , MonadTime m + , MonadTimer m , Ord ntnAddr , Show ntnAddr , Hashable ntnAddr ) - => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) + => Snocket m Cardano.LocalSocket LocalAddress + -> Mx.MakeBearer m Cardano.LocalSocket + -> (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) -> Configuration -> StdGen - -> (NetworkMagic -> NodeKernel crypto ntnAddr m -> m (Either SomeException Void)) -> (NodeKernel crypto ntnAddr m -> m a) -- ^ as soon as the callback exits the `mempoolWorker` and all -- decision logic threads will be killed -> m a -withNodeKernel tracer +withNodeKernel localSnocket + mkLocalBearer + tracer Configuration { dmqcSigSubmissionLogicTracer = I sigSubmissionLogicTracer, - dmqcCardanoNetworkMagic = I networkMagic + dmqcCardanoNetworkMagic = I networkMagic, + dmqcCardanoNodeSocket = I cardanoNodeSocketPath, + dmqcLocalStateQueryTracer = I localStateQueryTracer, + dmqcLedgerPeers = I ledgerPeers } rng - mkStakePoolMonitor k = do + k = do nodeKernel@NodeKernel { mempool, sigChannelVar, sigSharedTxStateVar @@ -211,11 +194,79 @@ withNodeKernel tracer sigChannelVar sigSharedTxStateVar) $ \sigLogicThread -> - withAsync (mkStakePoolMonitor networkMagic nodeKernel) \spmAid -> do + withAsync (connectToCardanoNode nodeKernel) \spmAid -> do link mempoolThread link sigLogicThread link spmAid k nodeKernel + where + connectToCardanoNode :: NodeKernel crypto ntnAddr m + -> m (Either SomeException Void) + connectToCardanoNode nodeKernel = + fmap fn <$> + connectToNode + localSnocket + mkLocalBearer + ConnectToArgs { + ctaHandshakeCodec = Cardano.nodeToClientHandshakeCodec, + ctaHandshakeTimeLimits = noTimeLimitsHandshake, + ctaVersionDataCodec = cborTermVersionDataCodec Cardano.NtoC.nodeToClientCodecCBORTerm, + ctaConnectTracers = Cardano.nullNetworkConnectTracers, --debuggingNetworkConnectTracers, + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + } + (\_ -> return ()) + (Cardano.combineVersions + [ Cardano.simpleSingletonVersions + version + Cardano.NodeToClientVersionData { + Cardano.networkMagic + , Cardano.query = False + } + \_version -> + Mx.OuroborosApplication + [ Mx.MiniProtocol + { Mx.miniProtocolNum = Mx.MiniProtocolNum 7 + , Mx.miniProtocolStart = Mx.StartEagerly + , Mx.miniProtocolLimits = + Mx.MiniProtocolLimits + { Mx.maximumIngressQueue = 0xffffffff + } + , Mx.miniProtocolRun = + Mx.InitiatorProtocolOnly + . Mx.mkMiniProtocolCbFromPeerSt + . const + $ ( nullTracer -- TODO: add tracer + , cStateQueryCodec + , StateIdle + , localStateQueryClientPeer $ + cardanoLocalStateQueryClient + (if localStateQueryTracer + then WithEventType "LocalStateQuery" >$< tracer + else nullTracer) + ledgerPeers + (stakePools nodeKernel) + (nextEpochVar nodeKernel) + ) + } + ] + | version <- [minBound..maxBound] + , let -- NOTE: the query protocol is running using + -- `Cardano.StandardCrypto`, while `dmq-node` is using + -- `StandardCrypto` defined in `kes-agent-krypto`. A priori + -- cryptography could differ but it shouldn't be a problem. We + -- are querying + supportedVersionMap = + supportedNodeToClientVersions (Proxy :: Proxy (CardanoBlock Cardano.StandardCrypto)) + blk = supportedVersionMap Map.! version + Codecs {cStateQueryCodec} = + clientCodecs (pClientInfoCodecConfig . protocolClientInfoCardano $ EpochSlots 21600) + blk version + ]) + Nothing + (localAddressFromPath cardanoNodeSocketPath) + where + fn :: forall x. Either x Void -> x + fn = either id absurd mempoolWorker :: forall crypto m. diff --git a/dmq-node/src/DMQ/Diffusion/NodeKernel/Types.hs b/dmq-node/src/DMQ/Diffusion/NodeKernel/Types.hs new file mode 100644 index 0000000..7b89919 --- /dev/null +++ b/dmq-node/src/DMQ/Diffusion/NodeKernel/Types.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} + +module DMQ.Diffusion.NodeKernel.Types + ( NodeKernel (..) + , PoolId + , StakePools (..) + , PoolValidationCtx (..) + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadTime.SI + + +import Data.Map.Strict (Map) +import Data.Word +import System.Random (StdGen) + +import Cardano.Ledger.Api.State.Query qualified as LedgerQuery +import Cardano.Ledger.Shelley.API qualified as Ledger + +import Ouroboros.Network.BlockFetch (FetchClientRegistry) +import Ouroboros.Network.ConnectionId (ConnectionId (..)) +import Ouroboros.Network.PeerSelection (LedgerPeerSnapshot, + LedgerPeersKind (..)) +import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry) +import Ouroboros.Network.TxSubmission.Inbound.V2 +import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool (..)) + +import DMQ.Protocol.SigSubmission.Type (Sig (..), SigId) + + +data NodeKernel crypto ntnAddr m = + NodeKernel { + -- | The fetch client registry, used for the keep alive clients. + fetchClientRegistry :: !(FetchClientRegistry (ConnectionId ntnAddr) () () m) + + -- | Read the current peer sharing registry, used for interacting with + -- the PeerSharing protocol + , peerSharingRegistry :: !(PeerSharingRegistry ntnAddr m) + , peerSharingAPI :: !(PeerSharingAPI ntnAddr StdGen m) + , mempool :: !(Mempool m SigId (Sig crypto)) + , sigChannelVar :: !(TxChannelsVar m ntnAddr SigId (Sig crypto)) + , sigMempoolSem :: !(TxMempoolSem m) + , sigSharedTxStateVar :: !(SharedTxStateVar m ntnAddr SigId (Sig crypto)) + , stakePools :: !(StakePools m) + , nextEpochVar :: !(StrictTVar m (Maybe UTCTime)) + } + +-- | Cardano pool id's are hashes of the cold verification key +-- +type PoolId = Ledger.KeyHash Ledger.StakePool + +data StakePools m = StakePools { + -- | contains map of cardano pool stake snapshot obtained + -- via local state query client + stakePoolsVar + :: !(StrictTVar m (Map PoolId LedgerQuery.StakeSnapshot)) + -- | Acquire and update validation context for signature validation + , withPoolValidationCtx + :: forall a. (PoolValidationCtx -> (a, PoolValidationCtx)) -> STM m a + -- | provides only those big peers which provide SRV endpoints + -- as otherwise those are cardano-nodes + , ledgerBigPeersVar + :: !(StrictTVar m (Maybe (LedgerPeerSnapshot BigLedgerPeers))) + -- | all ledger peers, restricted to srv endpoints + , ledgerPeersVar + :: !(StrictTMVar m (LedgerPeerSnapshot AllLedgerPeers)) + } + +data PoolValidationCtx = + PoolValidationCtx { + vctxEpoch :: !(Maybe UTCTime) + -- ^ UTC time of next epoch boundary for handling clock skew + , vctxStakeMap :: !(Map PoolId LedgerQuery.StakeSnapshot) + -- ^ for signature validation + , vctxOcertMap :: !(Map PoolId Word64) + -- ^ ocert counters to check monotonicity + } + deriving Show + diff --git a/dmq-node/src/DMQ/Diffusion/PeerSelection.hs b/dmq-node/src/DMQ/Diffusion/PeerSelection.hs index f916198..39996fb 100644 --- a/dmq-node/src/DMQ/Diffusion/PeerSelection.hs +++ b/dmq-node/src/DMQ/Diffusion/PeerSelection.hs @@ -6,14 +6,14 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Word (Word32) import Ouroboros.Network.PeerSelection -import System.Random (Random (..), StdGen, split) +import System.Random (Random (..), StdGen, splitGen) -- | Trivial peer selection policy used as dummy value -- policy :: forall peerAddr m. ( MonadSTM m , Ord peerAddr - ) + ) => StrictTVar m StdGen -> PeerSelectionPolicy peerAddr m policy rngVar = @@ -32,7 +32,9 @@ policy rngVar = policyPeerShareRetryTime = 0, -- seconds policyPeerShareBatchWaitTime = 0, -- seconds policyPeerShareOverallTimeout = 0, -- seconds - policyPeerShareActivationDelay = 2 -- seconds + policyPeerShareActivationDelay = 2, -- seconds + policyMaxConnectionRetries = 5, + policyClearFailCountDelay = 120 -- seconds } where hotDemotionPolicy :: PickPolicy peerAddr (STM m) @@ -108,7 +110,7 @@ addRand :: ( MonadSTM m addRand rngVar available scaleFn = do inRng <- readTVar rngVar - let (rng, rng') = split inRng + let (rng, rng') = splitGen inRng rns = take (Set.size available) $ unfoldr (Just . random) rng :: [Word32] available' = Map.fromList $ zipWith scaleFn (Set.toList available) rns writeTVar rngVar rng' diff --git a/dmq-node/src/DMQ/NodeToClient.hs b/dmq-node/src/DMQ/NodeToClient.hs index e2291bd..eb6e1de 100644 --- a/dmq-node/src/DMQ/NodeToClient.hs +++ b/dmq-node/src/DMQ/NodeToClient.hs @@ -134,7 +134,8 @@ _ntc_MAX_SIGS_TO_ACK = 1000 -- ntcApps :: forall crypto idx ntcAddr m. - ( MonadThrow m + ( MonadEvaluate m + , MonadThrow m , MonadThread m , MonadSTM m , Crypto crypto diff --git a/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs b/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs index c9f7265..a1bd72c 100644 --- a/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs +++ b/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs @@ -5,42 +5,42 @@ module DMQ.NodeToClient.LocalStateQueryClient ( TraceLocalStateQueryClient (..) - , cardanoClient - , connectToCardanoNode + , CardanoLocalStateQueryClient + , cardanoLocalStateQueryClient ) where import Control.Concurrent.Class.MonadSTM.Strict +import Control.DeepSeq (force) import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Monad.Trans.Except -import Control.Tracer (Tracer (..), nullTracer, traceWith) +import Control.Tracer (Tracer (..), traceWith) import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson qualified as Aeson -import Data.Map.Strict qualified as Map -import Data.Proxy +import Data.Functor ((<&>)) +import Data.List.NonEmpty qualified as NonEmpty import Data.Void -import Cardano.Chain.Slotting (EpochSlots(..)) -import Cardano.Network.NodeToClient +import Cardano.Ledger.Api.State.Query (StakeSnapshots (..)) +import Cardano.Network.PeerSelection (LedgerPeerSnapshot (..), + LedgerRelayAccessPoint (..)) import Cardano.Slotting.EpochInfo.API import Cardano.Slotting.Slot (EpochNo) import Cardano.Slotting.Time -import DMQ.Diffusion.NodeKernel +import DMQ.Diffusion.NodeKernel.Types (StakePools (..)) import Ouroboros.Consensus.Cardano.Block -import Ouroboros.Consensus.Cardano.Node import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query import Ouroboros.Consensus.HardFork.History.EpochInfo (interpreterToEpochInfo) import Ouroboros.Consensus.HardFork.History.Qry (PastHorizonException) import Ouroboros.Consensus.Ledger.Query (Query (..)) -import Ouroboros.Consensus.Network.NodeToClient -import Ouroboros.Consensus.Node.NetworkProtocolVersion -import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Shelley.Ledger.Query import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Network.Block -import Ouroboros.Network.Magic -import Ouroboros.Network.Mux qualified as Mx +import Ouroboros.Network.PeerSelection.LedgerPeers (LedgerPeersKind (..), + SomeLedgerPeerSnapshot (..), accumulateBigLedgerStake) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (SomeHashableBlock) +import Ouroboros.Network.Point (Block (..)) import Ouroboros.Network.Protocol.LocalStateQuery.Client import Ouroboros.Network.Protocol.LocalStateQuery.Type @@ -71,27 +71,61 @@ instance ToJSON TraceLocalStateQueryClient where , "error" .= show e ] --- TODO generalize to handle ledger eras other than Conway --- | connects the dmq node to cardano node via local state query --- and updates the node kernel with stake pool data necessary to perform message --- validation -- -cardanoClient - :: forall block query point crypto m. (MonadDelay m, MonadSTM m, MonadThrow m, MonadTime m) - => (block ~ CardanoBlock crypto, query ~ Query block, point ~ Point block) +-- Type aliases +-- + +-- | `LocalStateQuery` using `CardanoBlock` +type CardanoLocalStateQueryClient crypto m a = + LocalStateQueryClient (CardanoBlock crypto) + (Point (CardanoBlock crypto)) + (Query (CardanoBlock crypto)) m Void + +-- | `ClientStAcuiring` using `CardanoBlock` +type CardanoClientStAcquiring crypto m a = + ClientStAcquiring (CardanoBlock crypto) (Point (CardanoBlock crypto)) (Query (CardanoBlock crypto)) m a + +-- | `ClientStAcuired` using `CardanoBlock` +type CardanoClientStAcquired crypto m a = + ClientStAcquired (CardanoBlock crypto) (Point (CardanoBlock crypto)) (Query (CardanoBlock crypto)) m a + + +-- | Local state query client which queries cardano node for +-- +-- * stake pool data (for signature validation) +-- * ledger peers (for peer selection) +-- +-- TODO generalize to handle ledger eras other than Conway. +-- +cardanoLocalStateQueryClient + :: forall crypto m. + ( MonadDelay m + , MonadSTM m + , MonadThrow m + , MonadTime m + ) => Tracer m TraceLocalStateQueryClient + -> Bool -- ^ use ledger peers -> StakePools m -> StrictTVar m (Maybe UTCTime) -- ^ from node kernel - -> LocalStateQueryClient (CardanoBlock crypto) (Point block) (Query block) m Void -cardanoClient tracer StakePools { stakePoolsVar } nextEpochVar = - LocalStateQueryClient (idle Nothing) + -> CardanoLocalStateQueryClient crypto m Void +cardanoLocalStateQueryClient + tracer ledgerPeers + StakePools { + stakePoolsVar, + ledgerPeersVar, + ledgerBigPeersVar + } + nextEpochVar + = + LocalStateQueryClient (idle Nothing) where idle mSystemStart = do traceWith tracer $ Acquiring mSystemStart -- FIXME: switched to volatiletip for prerelease testing purposes pure $ SendMsgAcquire VolatileTip {-ImmutableTip-} acquire where - acquire :: ClientStAcquiring block point query m Void + acquire :: CardanoClientStAcquiring crypto m Void acquire = ClientStAcquiring { recvMsgAcquired = let epochQry systemStart = pure $ @@ -131,104 +165,99 @@ cardanoClient tracer StakePools { stakePoolsVar } nextEpochVar = idle $ Just systemStart Right relativeTime -> do let nextEpoch = fromRelativeTime systemStart relativeTime + -- continue with stake snapshot query + pure $ queryStakeSnapshots systemStart nextEpoch + + + -- query stake snapshot + queryStakeSnapshots + :: SystemStart + -> UTCTime + -> CardanoClientStAcquired crypto m Void + queryStakeSnapshots systemStart nextEpoch = + SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetStakeSnapshots Nothing) + $ wrappingMismatch handleStakeSnapshots + where + handleStakeSnapshots + :: StakeSnapshots + -> m (ClientStAcquired + (CardanoBlock crypto) + (Point (CardanoBlock crypto)) + (Query (CardanoBlock crypto)) + m + Void) + handleStakeSnapshots StakeSnapshots { ssStakeSnapshots } = do + atomically do + writeTVar stakePoolsVar ssStakeSnapshots + writeTVar nextEpochVar $ Just nextEpoch + toNextEpoch <- diffUTCTime nextEpoch <$> getCurrentTime + traceWith tracer $ NextEpoch nextEpoch toNextEpoch + threadDelay $ min (max 1 $ realToFrac toNextEpoch) 86400 -- TODO fuzz this? pure $ - SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetStakeSnapshots Nothing) - $ wrappingMismatch (handleStakeSnapshots systemStart nextEpoch) - - handleStakeSnapshots systemStart nextEpoch StakeSnapshots { ssStakeSnapshots } = - pure $ SendMsgRelease do - atomically do - writeTVar stakePoolsVar ssStakeSnapshots - writeTVar nextEpochVar $ Just nextEpoch - toNextEpoch <- diffUTCTime nextEpoch <$> getCurrentTime - traceWith tracer $ NextEpoch nextEpoch toNextEpoch - threadDelay $ min (max 1 $ realToFrac toNextEpoch) 86400 -- TODO fuzz this? - idle $ Just systemStart - - -- TODO uncomment once this functionality is integrated into cardano-node - -- pure $ - -- SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetLedgerPeerSnapshot AllLedgerPeers) - -- $ wrappingMismatch handleLedgerPeers - -- where - -- handleLedgerPeers (SomeLedgerPeerSnapshot (LedgerAllPeerSnapshotV23 pt magic peers)) = do - -- let bigSrvRelays = force - -- [(accStake, (stake, NonEmpty.fromList relays')) - -- | (accStake, (stake, relays)) <- accumulateBigLedgerStake peers - -- , let relays' = NonEmpty.filter - -- (\case - -- LedgerRelayAccessSRVDomain {} -> True - -- _ -> False - -- ) - -- relays - -- , not (null relays') - -- ] - -- pt' = Point $ getPoint pt <&> - -- \blk -> blk { blockPointSlot = maxBound } - -- srvRelays = force - -- [ (stake, NonEmpty.fromList relays') - -- | (stake, relays) <- peers - -- , let relays' = NonEmpty.filter - -- (\case - -- LedgerRelayAccessSRVDomain {} -> True - -- _ -> False - -- ) - -- relays - -- , not (null relays') - -- ] - -- atomically do - -- writeTMVar ledgerPeersVar $ LedgerAllPeerSnapshotV23 pt magic srvRelays - -- writeTVar ledgerBigPeersVar . Just $! LedgerBigPeerSnapshotV23 pt' magic bigSrvRelays - -- pure $ SendMsgRelease do - -- threadDelay $ min (realToFrac toNextEpoch) 86400 -- TODO fuzz this? - -- idle $ Just systemStart - - -- handleLedgerPeers _ = error "handleLedgerPeers: impossible!" - - -connectToCardanoNode :: Tracer IO TraceLocalStateQueryClient - -> LocalSnocket - -> FilePath - -> NetworkMagic - -> NodeKernel crypto ntnAddr IO - -> IO (Either SomeException Void) -connectToCardanoNode tracer localSnocket' snocketPath networkMagic nodeKernel = - connectTo - localSnocket' - nullNetworkConnectTracers --debuggingNetworkConnectTracers - (combineVersions - [ simpleSingletonVersions - version - NodeToClientVersionData { - networkMagic - , query = False - } - \_version -> - Mx.OuroborosApplication - [ Mx.MiniProtocol - { miniProtocolNum = Mx.MiniProtocolNum 7 - , miniProtocolStart = Mx.StartEagerly - , miniProtocolLimits = - Mx.MiniProtocolLimits - { maximumIngressQueue = 0xffffffff - } - , miniProtocolRun = - Mx.InitiatorProtocolOnly - . Mx.mkMiniProtocolCbFromPeerSt - . const - $ ( nullTracer -- TODO: add tracer - , cStateQueryCodec - , StateIdle - , localStateQueryClientPeer - $ cardanoClient tracer - (stakePools nodeKernel) - (nextEpochVar nodeKernel) - ) - } - ] - | version <- [minBound..maxBound] - , let supportedVersionMap = supportedNodeToClientVersions (Proxy :: Proxy (CardanoBlock StandardCrypto)) - blk = supportedVersionMap Map.! version - Codecs {cStateQueryCodec} = - clientCodecs (pClientInfoCodecConfig . protocolClientInfoCardano $ EpochSlots 21600) blk version - ]) - snocketPath + if ledgerPeers + then -- continue with ledger peers query + queryLedgerPeers systemStart toNextEpoch + else -- release and continue in the idle state + release systemStart toNextEpoch + + + -- query ledger peer snapshot + queryLedgerPeers + :: SystemStart + -> NominalDiffTime + -> CardanoClientStAcquired crypto m Void + queryLedgerPeers systemStart toNextEpoch = + SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetLedgerPeerSnapshot AllLedgerPeers) + $ wrappingMismatch handleLedgerPeers + where + handleLedgerPeers + :: SomeLedgerPeerSnapshot + -> m (ClientStAcquired + (CardanoBlock crypto) + (Point (CardanoBlock crypto)) + (Query (CardanoBlock crypto)) + m + Void) + handleLedgerPeers (SomeLedgerPeerSnapshot _ (LedgerAllPeerSnapshotV23 pt magic peers)) = do + let bigSrvRelays = force + [(accStake, (stake, NonEmpty.fromList relays')) + | (accStake, (stake, relays)) <- accumulateBigLedgerStake peers + , let relays' = NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> True + _ -> False + ) + relays + , not (null relays') + ] + pt' :: Point SomeHashableBlock + pt' = Point $ getPoint pt <&> + \blk -> blk { blockPointSlot = maxBound } + srvRelays = force + [ (stake, NonEmpty.fromList relays') + | (stake, relays) <- peers + , let relays' = NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> True + _ -> False + ) + relays + , not (null relays') + ] + + atomically do + writeTMVar ledgerPeersVar $ LedgerAllPeerSnapshotV23 pt magic srvRelays + writeTVar ledgerBigPeersVar . Just $! LedgerBigPeerSnapshotV23 pt' magic bigSrvRelays + + pure $ release systemStart toNextEpoch + + handleLedgerPeers _ = error "handleLedgerPeers: impossible!" + + + -- release, continue the loop in `idle` + release :: SystemStart + -> NominalDiffTime + -> CardanoClientStAcquired crypto m Void + release systemStart toNextEpoch = SendMsgRelease do + threadDelay $ min (realToFrac toNextEpoch) 86400 -- TODO fuzz this? + idle $ Just systemStart diff --git a/dmq-node/src/DMQ/NodeToClient/Version.hs b/dmq-node/src/DMQ/NodeToClient/Version.hs index 5b5b117..f164827 100644 --- a/dmq-node/src/DMQ/NodeToClient/Version.hs +++ b/dmq-node/src/DMQ/NodeToClient/Version.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module DMQ.NodeToClient.Version ( NodeToClientVersion (..) @@ -77,7 +78,8 @@ data NodeToClientVersionData = NodeToClientVersionData { networkMagic :: !NetworkMagic , query :: !Bool } - deriving (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving anyclass NFData instance Aeson.ToJSON NodeToClientVersionData where toJSON NodeToClientVersionData { diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs index a489f08..c6f19b1 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -114,7 +114,7 @@ import Ouroboros.Network.Protocol.TxSubmission2.Server -- This makes sense, since `ctx` already contains `versionData`. type ClientApp addr m a = NodeToNodeVersion - -> ExpandedInitiatorContext addr m + -> ExpandedInitiatorContext addr NoExtraFlags m -> Channel m BL.ByteString -> m (a, Maybe BL.ByteString) @@ -152,6 +152,7 @@ ntnApps , Alternative (STM m) , MonadAsync m , MonadDelay m + , MonadEvaluate m , MonadFork m , MonadMask m , MonadMVar m @@ -225,7 +226,7 @@ ntnApps where aSigSubmissionClient :: NodeToNodeVersion - -> ExpandedInitiatorContext addr m + -> ExpandedInitiatorContext addr NoExtraFlags m -> Channel m BL.ByteString -> m ((), Maybe BL.ByteString) aSigSubmissionClient version @@ -291,7 +292,7 @@ ntnApps aKeepAliveClient :: NodeToNodeVersion - -> ExpandedInitiatorContext addr m + -> ExpandedInitiatorContext addr NoExtraFlags m -> Channel m BL.ByteString -> m ((), Maybe BL.ByteString) aKeepAliveClient _version @@ -345,7 +346,7 @@ ntnApps aPeerSharingClient :: NodeToNodeVersion - -> ExpandedInitiatorContext addr m + -> ExpandedInitiatorContext addr NoExtraFlags m -> Channel m BL.ByteString -> m ((), Maybe BL.ByteString) aPeerSharingClient _version @@ -479,7 +480,7 @@ initiatorProtocols -> Apps addr m a b -> NodeToNodeVersion -> NodeToNodeVersionData - -> OuroborosBundleWithExpandedCtx 'InitiatorMode addr BL.ByteString m a Void + -> OuroborosBundleWithExpandedCtx 'InitiatorMode addr NoExtraFlags BL.ByteString m a Void initiatorProtocols limitsAndTimeouts Apps { aSigSubmissionClient @@ -504,7 +505,7 @@ initiatorAndResponderProtocols -> Apps addr m a b -> NodeToNodeVersion -> NodeToNodeVersionData - -> OuroborosBundleWithExpandedCtx 'InitiatorResponderMode addr BL.ByteString m a b + -> OuroborosBundleWithExpandedCtx 'InitiatorResponderMode addr NoExtraFlags BL.ByteString m a b initiatorAndResponderProtocols limitsAndTimeouts Apps { aSigSubmissionClient diff --git a/dmq-node/src/DMQ/NodeToNode/Version.hs b/dmq-node/src/DMQ/NodeToNode/Version.hs index 752c97a..316b962 100644 --- a/dmq-node/src/DMQ/NodeToNode/Version.hs +++ b/dmq-node/src/DMQ/NodeToNode/Version.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module DMQ.NodeToNode.Version ( NodeToNodeVersion (..) @@ -64,7 +65,8 @@ data NodeToNodeVersionData = NodeToNodeVersionData , peerSharing :: !PeerSharing , query :: !Bool } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass NFData instance Aeson.ToJSON NodeToNodeVersionData where toJSON NodeToNodeVersionData { diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs index 93ea812..c55f39f 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs @@ -13,9 +13,9 @@ module DMQ.Protocol.LocalMsgSubmission.Type , module Ouroboros ) where +import DMQ.Protocol.SigSubmission.Validate (SigValidationError (..)) import Network.TypedProtocol.Core as Core import Ouroboros.Network.Protocol.LocalTxSubmission.Type as Ouroboros -import DMQ.Protocol.SigSubmission.Validate (SigValidationError (..)) -- | The LocalMsgSubmission protocol is an alias for the LocalTxSubmission -- diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs index 6fc1143..001409b 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -16,10 +16,10 @@ module DMQ.Protocol.SigSubmission.Validate where import Control.Exception (Exception (..)) import Control.Monad.Class.MonadTime.SI -import Control.Monad.State.Strict (State, StateT (..)) -import Control.Monad.State.Strict qualified as State import Control.Monad.Except (Except) import Control.Monad.Except qualified as Except +import Control.Monad.State.Strict (State, StateT (..)) +import Control.Monad.State.Strict qualified as State import Data.Aeson import Data.ByteString (ByteString) @@ -34,12 +34,12 @@ import Cardano.Crypto.DSIGN.Class qualified as DSIGN import Cardano.Crypto.KES.Class (KESAlgorithm (..)) import Cardano.KESAgent.KES.Crypto as KES import Cardano.KESAgent.KES.OCert (OCert (..), OCertSignable, validateOCert) +import Cardano.Ledger.Api.State.Query (StakeSnapshot (..)) import Cardano.Ledger.BaseTypes.NonZero qualified as Ledger import Cardano.Ledger.Keys qualified as Ledger import DMQ.Diffusion.NodeKernel (PoolValidationCtx (..)) import DMQ.Protocol.SigSubmission.Type -import Ouroboros.Consensus.Shelley.Ledger.Query import Ouroboros.Network.Util.ShowProxy @@ -88,7 +88,7 @@ data SigValidationTrace = InvalidSignature SigId SigValidationError deriving Show instance ToJSON SigValidationTrace where - toJSON (InvalidSignature sigid reason) = object + toJSON (InvalidSignature sigid reason) = object [ "type" .= String "InvalidSignature" , "sigid" .= sigid , "reason" .= reason diff --git a/dmq-node/src/DMQ/Tracer.hs b/dmq-node/src/DMQ/Tracer.hs index 9643f81..982d986 100644 --- a/dmq-node/src/DMQ/Tracer.hs +++ b/dmq-node/src/DMQ/Tracer.hs @@ -186,9 +186,7 @@ dmqDiffusionTracers dmqcTracePublicRootPeersTracer = I tracePublicRootPeersTracer, dmqcTraceLedgerPeersTracer = I traceLedgerPeersTracer, dmqcTracePeerSelectionTracer = I tracePeerSelectionTracer, - dmqcTraceChurnCounters = I traceChurnCounters, - dmqcDebugPeerSelectionInitiatorTracer = I debugPeerSelectionInitiatorTracer, - dmqcDebugPeerSelectionInitiatorResponderTracer = I debugPeerSelectionInitiatorResponderTracer, + dmqcDebugPeerSelectionTracer = I debugPeerSelectionTracer, dmqcTracePeerSelectionCounters = I tracePeerSelectionCounters, dmqcPeerSelectionActionsTracer = I peerSelectionActionsTracer, dmqcConnectionManagerTracer = I connectionManagerTracer, @@ -229,14 +227,10 @@ dmqDiffusionTracers .- WithEventType "LedgerPeers" >$< tracer, Diffusion.dtTracePeerSelectionTracer = tracePeerSelectionTracer .- WithEventType "PeerSelection" >$< tracer, - Diffusion.dtDebugPeerSelectionInitiatorTracer = debugPeerSelectionInitiatorTracer - .- WithEventType "DebugPeerSelectionInitiator" >$< tracer, - Diffusion.dtDebugPeerSelectionInitiatorResponderTracer = debugPeerSelectionInitiatorResponderTracer - .- WithEventType "DebugPeerSelectionInitiatorResponder" >$< tracer, + Diffusion.dtDebugPeerSelectionTracer = debugPeerSelectionTracer + .- WithEventType "DebugPeerSelection" >$< tracer, Diffusion.dtTracePeerSelectionCounters = tracePeerSelectionCounters .- WithEventType "PeerSelectionCounters" >$< tracer, - Diffusion.dtTraceChurnCounters = traceChurnCounters - .- WithEventType "ChurnCounters" >$< tracer, Diffusion.dtPeerSelectionActionsTracer = peerSelectionActionsTracer .- WithEventType "PeerSelectionActions" >$< tracer, Diffusion.dtConnectionManagerTracer = connectionManagerTracer diff --git a/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Test.hs b/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Test.hs index 7260704..6e53cd2 100644 --- a/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Test.hs +++ b/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Test.hs @@ -11,6 +11,7 @@ module DMQ.Protocol.LocalMsgNotification.Test where import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR import Codec.Serialise (DeserialiseFailure, Serialise (..)) +import Control.DeepSeq (NFData (..)) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow @@ -112,7 +113,11 @@ prop_connect (Positive maxMsgs) (DistinctNEList msgs) = -- | Run a local tx-submission client and server using connected channels. -- -prop_channel :: (MonadAsync m, MonadCatch m, MonadST m) +prop_channel :: ( MonadAsync m + , MonadCatch m + , MonadEvaluate m + , MonadST m + ) => m (Channel m ByteString, Channel m ByteString) -> Positive Word16 -> DistinctNEList MsgWithBytes @@ -202,6 +207,7 @@ type LocalMsgNotificationCodec m msg = newtype Msg = Msg Int deriving stock (Show, Eq) + deriving newtype NFData deriving newtype Arbitrary deriving newtype Serialise -- TODO: why do I need this instance? @@ -214,6 +220,12 @@ decodeMsg = const . Msg <$> CBOR.decodeInt type MsgWithBytes = WithBytes Msg +instance NFData (WithBytes Msg) where + rnf WithBytes {cborBytes, cborPayload} = + rnf cborBytes + `seq` + rnf cborPayload + instance ShowProxy (WithBytes Msg) where showProxy _ = "WithBytes Msg" diff --git a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs index 6d0720f..f14f09c 100644 --- a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs +++ b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs @@ -50,22 +50,22 @@ import Cardano.Crypto.KES.Class (KESAlgorithm (..), VerKeyKES, encodeSigKES) import Cardano.Crypto.KES.Class qualified as KES import Cardano.Crypto.PinnedSizedBytes (PinnedSizedBytes, psbToByteString) import Cardano.Crypto.Seed (mkSeedFromBytes) -import Cardano.Ledger.Keys (VKey (..)) -import Cardano.Ledger.Keys qualified as Ledger.Keys -import Cardano.Ledger.Hashes (hashKey) import Cardano.KESAgent.KES.Crypto (Crypto (..)) import Cardano.KESAgent.KES.Evolution qualified as KES import Cardano.KESAgent.KES.OCert (OCert (..)) import Cardano.KESAgent.KES.OCert qualified as KES import Cardano.KESAgent.Protocols.StandardCrypto (MockCrypto, StandardCrypto) +import Cardano.Ledger.Api.State.Query (StakeSnapshot (..)) +import Cardano.Ledger.Hashes (hashKey) +import Cardano.Ledger.Keys (VKey (..)) +import Cardano.Ledger.Keys qualified as Ledger.Keys import Test.Crypto.Instances -import DMQ.Diffusion.NodeKernel (PoolValidationCtx(..)) +import DMQ.Diffusion.NodeKernel (PoolValidationCtx (..)) import DMQ.Protocol.SigSubmission.Codec import DMQ.Protocol.SigSubmission.Type import DMQ.Protocol.SigSubmission.Validate -import Ouroboros.Consensus.Shelley.Ledger.Query (StakeSnapshot (..)) import Ouroboros.Network.Protocol.TxSubmission2.Test (labelMsg) import Test.Ouroboros.Network.Protocol.Utils (prop_codec_cborM, @@ -975,7 +975,7 @@ prop_validateSig constr validity = ioProperty do case validity of InvalidViaNotInitialized -> Map.empty InvalidViaUnrecognizedPool -> Map.empty - _ -> Map.fromList [(poolId, stakeSnapshot)] + _ -> Map.fromList [(poolId, stakeSnapshot)] vctxOcertMap = case validity of diff --git a/flake.lock b/flake.lock index afbbf5a..5b60ffe 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1768416233, - "narHash": "sha256-i2c7coWF4U8y9WwiwAQGu3RkLlJJUQgomBPqsuZ7aNc=", + "lastModified": 1772012597, + "narHash": "sha256-Zz/hOrvN5Ys3u0pn/PAfMwEnX3vBEzt3dfBdMbPBX/w=", "owner": "IntersectMBO", "repo": "cardano-haskell-packages", - "rev": "cb466bebf83011b95108c2bb1d2a7514446fc11b", + "rev": "2d0e916916f5bfa7e8d773ebf3c01c5f4f489da7", "type": "github" }, "original": { @@ -155,11 +155,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1764587895, - "narHash": "sha256-RS4RgaPDCu73t5yq6dRIP4vz4v9/NlOuPoA1na8QPIs=", + "lastModified": 1772001687, + "narHash": "sha256-ptZzrJLnqA7P4AYYFv4mA2f+xTmXsHclTFhe6aRmwLs=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "d6c0c5509f290c7da906fb42ba5e6d8200ff3490", + "rev": "e12ead50fba1c5b6e9e7e8b31680550ef38f3242", "type": "github" }, "original": { diff --git a/nix/project.nix b/nix/dmq-node.nix similarity index 92% rename from nix/project.nix rename to nix/dmq-node.nix index 3aa0ab9..82f8918 100644 --- a/nix/project.nix +++ b/nix/dmq-node.nix @@ -1,6 +1,9 @@ -{ inputs, pkgs, lib }: +inputs: final: prev: let + inherit (prev) lib; + inherit (prev) pkgs; + buildSystem = pkgs.stdenv.buildPlatform.system; onLinux = buildSystem == "x86_64-linux"; @@ -17,7 +20,7 @@ let }); }; - cabalProject = pkgs.haskell-nix.cabalProject' ( + dmq-node = pkgs.haskell-nix.cabalProject' ( { config, pkgs, ... }: @@ -33,7 +36,7 @@ let (lib.genAttrs otherCompilers (compiler-nix-name: { inherit compiler-nix-name; })) // { ${defaultCompiler} = { }; }; # placeholder to access - # defaultCompiler in `nix/shell.nix` + # defaultCompiler in `nix/shell.nix` inputMap = { "https://chap.intersectmbo.org/" = inputs.CHaP; }; @@ -68,5 +71,4 @@ let ); in - -cabalProject +{ inherit dmq-node; } diff --git a/nix/formatting.nix b/nix/formatting.nix new file mode 100644 index 0000000..0292b71 --- /dev/null +++ b/nix/formatting.nix @@ -0,0 +1,34 @@ +pkgs: + +let + inherit (pkgs) lib; + checkFormatting = tool: script: opts: pkgs.runCommand + "check-${lib.getName tool}" + { + buildInputs = [ pkgs.fd pkgs.which tool ]; + src = ../.; + } '' + unpackPhase + cd $sourceRoot + + bash ${script} ${opts} + + EXIT_CODE=0 + diff -ru $src . || EXIT_CODE=$? + + if [[ $EXIT_CODE != 0 ]] + then + echo "*** ${tool.name} found changes that need addressed first" + exit $EXIT_CODE + else + echo $EXIT_CODE >> $out + fi + ''; +in +{ + stylish-haskell = checkFormatting pkgs.stylish-haskell ../scripts/ci/run-stylish-haskell.sh "-g"; + nixpkgs-fmt = checkFormatting pkgs.nixpkgs-fmt ../scripts/ci/run-nixpkgs-fmt.sh ""; + cabal-gild = checkFormatting pkgs.cabal-gild ../scripts/ci/run-cabal-gild.sh ""; + # cabal-check = checkFormatting pkgs.cabal ../scripts/ci/run-cabal-check.sh ""; +} + diff --git a/nix/outputs.nix b/nix/outputs.nix index 967bb04..0a9182b 100644 --- a/nix/outputs.nix +++ b/nix/outputs.nix @@ -3,13 +3,12 @@ let inherit (pkgs) lib; + # pkgs contains `dmq-node` included as an overlay of nixpkgs pkgs = import ./pkgs.nix { inherit inputs system; }; utils = import ./utils.nix { inherit pkgs lib; }; - project = import ./project.nix { inherit inputs pkgs lib; }; - - mkShell = ghc: import ./shell.nix { inherit inputs pkgs lib project utils ghc; }; + mkShell = ghc: import ./shell.nix { inherit inputs pkgs lib utils ghc; }; buildSystem = pkgs.stdenv.buildPlatform.system; @@ -20,13 +19,13 @@ let # setGitRev broken? # pkgs.setGitRev # (inputs.self.rev or inputs.self.dirtyShortRev) - project.hsPkgs.dmq-node.components.exes.dmq-node; + pkgs.dmq-node.hsPkgs.dmq-node.components.exes.dmq-node; default = dmq-node; } // lib.optionalAttrs (buildSystem == "x86_64-linux") { dmq-node-static = # pkgs.setGitRev # (inputs.self.rev or inputs.self.dirtyShortRev) - project.projectCross.musl64.hsPkgs.dmq-node.components.exes.dmq-node; + pkgs.dmq-node.projectCross.musl64.hsPkgs.dmq-node.components.exes.dmq-node; docker-dmq = pkgs.dockerTools.buildImage { name = "docker-dmq-node"; tag = "latest"; @@ -55,12 +54,14 @@ let # ghc9122 = mkShell "ghc9122"; }; - flake = project.flake { }; + flake = pkgs.dmq-node.flake { }; + format = pkgs.callPackage ./formatting.nix pkgs; defaultHydraJobs = { ciJobs = flake.hydraJobs; inherit packages; inherit devShells; + inherit format; required = utils.makeHydraRequiredJob hydraJobs; }; @@ -79,5 +80,16 @@ in inherit app; inherit devShells; inherit hydraJobs; - __internal = { inherit pkgs project; }; + legacyPackages = { + format = + format + // { + all = pkgs.releaseTools.aggregate { + name = "dmq-node-format"; + meta.description = "Run all formatters"; + constituents = lib.collect lib.isDerivation format; + }; + }; + }; + __internal = { inherit pkgs; }; } diff --git a/nix/pkgs.nix b/nix/pkgs.nix index b9292f5..9b167b2 100644 --- a/nix/pkgs.nix +++ b/nix/pkgs.nix @@ -25,5 +25,7 @@ import inputs.nixpkgs { postFixup = ""; }); }) + (import ./tools.nix inputs) + (import ./dmq-node.nix inputs) ]; } diff --git a/nix/shell.nix b/nix/shell.nix index 30f57d1..dc2c401 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -1,7 +1,8 @@ -{ inputs, pkgs, lib, project, utils, ghc }: +{ inputs, pkgs, lib, utils, ghc }: let - tool = project.projectVariants.${ghc}.tool; + dmq-node = pkgs.dmq-node; + tool = dmq-node.projectVariants.${ghc}.tool; tools = { cabal = tool "cabal" "latest"; cabal-gild = tool "cabal-gild" "latest"; @@ -35,7 +36,7 @@ let pkgs.which ]; - shell = project.shellFor { + shell = dmq-node.shellFor { name = "dmq-node-shell-${ghc}"; buildInputs = lib.concatLists [ diff --git a/nix/tools.nix b/nix/tools.nix new file mode 100644 index 0000000..2e6b9be --- /dev/null +++ b/nix/tools.nix @@ -0,0 +1,24 @@ +inputs: final: prev: + +let + inherit (final) lib; + tool-index-state = "2026-02-17T10:15:41Z"; + tool = name: version: other: + final.haskell-nix.tool final.dmq-node.args.compiler-nix-name name ({ + version = version; + index-state = tool-index-state; + } // other); +in +{ + inherit tool-index-state; + # cabal = tool "cabal" "3.12.1.0" { }; + cabal-gild = tool "cabal-gild" "1.5.0.1" { }; + stylish-haskell = tool "stylish-haskell" "0.14.6.0" { }; + haskellBuildUtils = prev.haskellBuildUtils.override { + inherit (final.ouroboros-network.args) compiler-nix-name; + index-state = tool-index-state; + }; + # remove once our nixpkgs contains https://github.com/NixOS/nixpkgs/pull/394873 + # cddlc = final.callPackage ./cddlc/package.nix { }; +} + diff --git a/scripts/ci/run-cabal-check.sh b/scripts/ci/run-cabal-check.sh new file mode 100755 index 0000000..5c242e6 --- /dev/null +++ b/scripts/ci/run-cabal-check.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +set -eo pipefail + +FD="$(which fdfind 2>/dev/null || which fd 2>/dev/null)" + +for x in $($FD -e cabal); do + ( + d=$(dirname $x) + echo "== $d ==" + pushd $d + cabal check + popd + ) +done diff --git a/scripts/ci/run-cabal-gild.sh b/scripts/ci/run-cabal-gild.sh new file mode 100755 index 0000000..58bec70 --- /dev/null +++ b/scripts/ci/run-cabal-gild.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +set -euo pipefail + +# First, try to find the 'fd' command +FD="$(which fdfind 2>/dev/null || which fd 2>/dev/null)" + +$FD --full-path "$(pwd)" -e cabal -x cabal-gild -i {} -o {} diff --git a/scripts/ci/run-nixpkgs-fmt.sh b/scripts/ci/run-nixpkgs-fmt.sh new file mode 100755 index 0000000..a4cf8f3 --- /dev/null +++ b/scripts/ci/run-nixpkgs-fmt.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +set -euo pipefail + +fd -e nix -X nixpkgs-fmt diff --git a/scripts/ci/run-stylish-haskell.sh b/scripts/ci/run-stylish-haskell.sh new file mode 100755 index 0000000..bbc2ef1 --- /dev/null +++ b/scripts/ci/run-stylish-haskell.sh @@ -0,0 +1,69 @@ +#!/usr/bin/env bash + +set -euo pipefail + +function usage { + echo "Usage $(basename "$0") [-ch]" + echo "Check files with 'stylish-haskell'; by default check all files." + echo + echo " -u only check uncommitted files" + echo " -c only check committed files in HEAD" + echo " -h this help message" + echo " -g don't show the diff with git" + exit +} + +export LC_ALL=C.UTF-8 + +STYLISH_HASKELL_ARGS="-c .stylish-haskell.yaml -i" +USE_GIT=1 + +optstring=":uchg" +while getopts ${optstring} arg; do + case ${arg} in + h) + usage; + exit 0 + ;; + g) + USE_GIT=0 + ;; + c) + PATHS=$(git show --pretty='' --name-only HEAD) + for path in $PATHS; do + echo $path + fd -e hs --ignore-file ./scripts/ci/check-stylish-ignore --full-path $path -X stylish-haskell $STYLISH_HASKELL_ARGS + done + if [ $USE_GIT == 1 ]; then + git --no-pager diff --exit-code + fi + exit 0 + ;; + u) + PATHS=$(git diff --name-only HEAD) + for path in $PATHS; do + if [ "${path##*.}" == "hs" ]; then + echo $path + fd -e hs --ignore-file ./scripts/ci/check-stylish-ignore --full-path $path -X stylish-haskell $STYLISH_HASKELL_ARGS + fi + done + if [ $USE_GIT == 1 ]; then + git --no-pager diff --exit-code + fi + exit 0 + ;; + ?) + echo "Invalid argument ${arg}" + exit 1 + ;; + esac +done + +# TODO CPP pragmas in export lists are not supported by stylish-haskell +FD_OPTS="-e hs --ignore-file ./scripts/ci/check-stylish-ignore -X stylish-haskell $STYLISH_HASKELL_ARGS" + +fd . './dmq-node' $FD_OPTS + +if [ $USE_GIT == 1 ]; then +git --no-pager diff --exit-code +fi