diff --git a/cabal.project b/cabal.project index d89ffe33196..901eec6e4ff 100644 --- a/cabal.project +++ b/cabal.project @@ -18,7 +18,7 @@ index-state: , hackage.haskell.org 2025-08-05T15:28:56Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2025-03-18T17:41:11Z + , cardano-haskell-packages 2025-09-10T02:05:10Z packages: ./cardano-ping ./monoidal-synchronisation @@ -55,10 +55,35 @@ package acts allow-newer: quickcheck-instances:QuickCheck +constraints: + QuickCheck <2.16 + +-- temp +source-repository-package + type: git + location: https://github.com/input-output-hk/typed-protocols + tag: e29a21541c4af44a3d586ef0b2a61f8d87cc6bdd + --sha256: + subdir: typed-protocols + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: b4c54f846afa8ef435fa401b0f6f4f9f5a6966d8 + --sha256: + subdir: + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + sop-extras + ouroboros-consensus-protocol + ouroboros-consensus + -- kes-agent is not yet in CHaP, so we pull it from its GitHub repo source-repository-package type: git - location: https://github.com/input-output-hk/kes-agent - tag: 6d0f51fba415d3c641a8a8da37130e7adfc3ea01 - --sha256: sha256-qM8RgmKOGBMlizPtXw2YOboYIzM6T3kvG9/Rp1F+bYQ= - subdir: kes-agent-crypto + location: https://github.com/crocodile-dentist/kes-agent + tag: c0ef04dde5582a28415ff7c8c1bb197adeec6fc8 + --sha256: + subdir: + kes-agent + kes-agent-crypto diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal index 7b1eb44914b..b0826075a2c 100644 --- a/cardano-diffusion/cardano-diffusion.cabal +++ b/cardano-diffusion/cardano-diffusion.cabal @@ -430,10 +430,13 @@ test-suite protocols-bench library cardano-diffusion-tests-lib import: ghc-options-tests + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + visibility: public hs-source-dirs: tests/lib build-depends: - QuickCheck >=2.16, + QuickCheck, aeson, base >=4.14 && <4.22, bytestring, @@ -453,6 +456,7 @@ library cardano-diffusion-tests-lib pipes, pretty-simple, psqueues, + quickcheck-monoids, random, serialise, tasty, diff --git a/cardano-diffusion/changelog.d/20251016_142053_coot_dmq_signature_validation.md b/cardano-diffusion/changelog.d/20251016_142053_coot_dmq_signature_validation.md new file mode 100644 index 00000000000..2f864c81146 --- /dev/null +++ b/cardano-diffusion/changelog.d/20251016_142053_coot_dmq_signature_validation.md @@ -0,0 +1,4 @@ +### Non-Breaking + +- Addapted tests to changes in the `Ouroboros.Network.TxSubmission.Mempool.Simple` API + diff --git a/cardano-diffusion/demo/chain-sync.hs b/cardano-diffusion/demo/chain-sync.hs index dcc375eded0..314e760c95e 100644 --- a/cardano-diffusion/demo/chain-sync.hs +++ b/cardano-diffusion/demo/chain-sync.hs @@ -75,8 +75,7 @@ import Ouroboros.Network.Protocol.BlockFetch.Type qualified as BlockFetch import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.Client import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientRegistry (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..), - initialWithFingerprint) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..)) import Ouroboros.Network.DeltaQ (defaultGSV) import Ouroboros.Network.Server.Simple qualified as Server.Simple @@ -436,10 +435,8 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do pure $ \p b -> addTestFetchedBlock blockHeap (castPoint p) (blockHeader b), - readChainComparison = pure $ initialWithFingerprint ChainComparison { - plausibleCandidateChain, - compareCandidateChains - }, + plausibleCandidateChain, + compareCandidateChains, blockFetchSize = \_ -> 1000, blockMatchesHeader = \_ _ -> True, @@ -453,8 +450,9 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do plausibleCandidateChain cur candidate = AF.headBlockNo candidate > AF.headBlockNo cur - headerForgeUTCTime = - convertSlotToTimeForTestsAssumingNoHardFork . headerSlot + headerForgeUTCTime (FromConsensus hdr) = + pure $ + convertSlotToTimeForTestsAssumingNoHardFork (headerSlot hdr) compareCandidateChains c1 c2 = AF.headBlockNo c1 `compare` AF.headBlockNo c2 diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs index f936c2855e6..b5093b0965b 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -104,6 +105,9 @@ import Test.Ouroboros.Network.TxSubmission.Types (Tx (..), TxId) import Test.Ouroboros.Network.Utils hiding (SmallDelay, debugTracer) import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty import Test.Tasty.QuickCheck (testProperty) diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs index e9e3a13c985..85129d03268 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs @@ -682,7 +682,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node txSubmissionInitiator :: TxDecisionPolicy - -> Mempool m (Tx TxId) + -> Mempool m TxId (Tx TxId) -> MiniProtocolCb (ExpandedInitiatorContext NtNAddr m) ByteString m () txSubmissionInitiator txDecisionPolicy mempool = MiniProtocolCb $ @@ -709,7 +709,7 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node (txSubmissionClientPeer client) txSubmissionResponder - :: Mempool m (Tx TxId) + :: Mempool m TxId (Tx TxId) -> TxChannelsVar m NtNAddr Int (Tx Int) -> TxMempoolSem m -> SharedTxStateVar m NtNAddr Int (Tx Int) diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs index 646a4713039..c4e47ecbeab 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs @@ -93,6 +93,7 @@ import Cardano.Network.PeerSelection.Governor.Types qualified as Cardano.ExtraSi import Cardano.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..)) import Test.QuickCheck +import Test.QuickCheck.Monoids import Test.Tasty import Test.Tasty.QuickCheck import Text.Pretty.Simple diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index edbda5e1d5f..025eb50f081 100644 --- a/dmq-node/app/Main.hs +++ b/dmq-node/app/Main.hs @@ -1,11 +1,16 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Main where +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (throwIO) import Control.Monad (void, when) import Control.Tracer (Tracer (..), nullTracer, traceWith) @@ -22,14 +27,17 @@ import System.Exit (exitSuccess) import System.Random (newStdGen, split) import Cardano.Git.Rev (gitRev) +import Cardano.KESAgent.KES.Evolution qualified as KES import Cardano.KESAgent.Protocols.StandardCrypto (StandardCrypto) +import Cardano.Ledger.Keys (VKey (..)) +import Cardano.Ledger.Hashes (hashKey) import DMQ.Configuration import DMQ.Configuration.CLIOptions (parseCLIOptions) import DMQ.Configuration.Topology (readTopologyFileOrError) import DMQ.Diffusion.Applications (diffusionApplications) import DMQ.Diffusion.Arguments -import DMQ.Diffusion.NodeKernel (mempool, withNodeKernel) +import DMQ.Diffusion.NodeKernel import DMQ.Handlers.TopLevel (toplevelExceptionHandler) import DMQ.NodeToClient qualified as NtC import DMQ.NodeToNode (NodeToNodeVersion, dmqCodecs, dmqLimitsAndTimeouts, @@ -39,9 +47,13 @@ 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.PeerSharing.Codec (decodeRemoteAddress, encodeRemoteAddress) +import Ouroboros.Network.SizeInBytes +import Ouroboros.Network.Snocket import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool import Paths_dmq_node qualified as Meta @@ -68,8 +80,10 @@ runDMQ commandLineConfig = do let dmqConfig@Configuration { dmqcPrettyLog = I prettyLog, dmqcTopologyFile = I topologyFile, + dmqcShelleyGenesisFile = I genesisFile, dmqcHandshakeTracer = I handshakeTracer, dmqcLocalHandshakeTracer = I localHandshakeTracer, + dmqcCardanoNodeSocket = I snocketPath, dmqcVersion = I version } = config' <> commandLineConfig `act` @@ -95,6 +109,12 @@ runDMQ commandLineConfig = do ] exitSuccess + res <- KES.evolutionConfigFromGenesisFile genesisFile + evolutionConfig <- case res of + Left err -> traceWith tracer (WithEventType "ShelleyGenesisFile" err) + >> throwIO (userError $ err) + Right ev -> return ev + traceWith tracer (WithEventType "Configuration" dmqConfig) nt <- readTopologyFileOrError topologyFile traceWith tracer (WithEventType "NetworkTopology" nt) @@ -102,48 +122,70 @@ runDMQ commandLineConfig = do stdGen <- newStdGen let (psRng, policyRng) = split stdGen - withNodeKernel @StandardCrypto tracer dmqConfig psRng $ \nodeKernel -> do - dmqDiffusionConfiguration <- mkDiffusionConfiguration dmqConfig nt - - let dmqNtNApps = - ntnApps tracer - dmqConfig - nodeKernel - (dmqCodecs - -- TODO: `maxBound :: Cardano.Network.NodeToNode.NodeToNodeVersion` - -- is unsafe here! - (encodeRemoteAddress (maxBound :: NodeToNodeVersion)) - (decodeRemoteAddress (maxBound :: NodeToNodeVersion))) - dmqLimitsAndTimeouts - defaultSigDecisionPolicy - dmqNtCApps = - let sigSize _ = 0 -- TODO - maxMsgs = 1000 -- TODO: make this dynamic? - mempoolReader = Mempool.getReader sigId sigSize (mempool nodeKernel) - mempoolWriter = Mempool.getWriter sigId (pure ()) - (\_ _ -> Right () :: Either Void ()) - (\_ -> True) - (mempool nodeKernel) - in NtC.ntcApps tracer dmqConfig - mempoolReader mempoolWriter maxMsgs - (NtC.dmqCodecs encodeReject decodeReject) - dmqDiffusionArguments = - diffusionArguments (if handshakeTracer - then WithEventType "Handshake" >$< tracer - else nullTracer) - (if localHandshakeTracer - then WithEventType "Handshake" >$< tracer - else nullTracer) - dmqDiffusionApplications = - diffusionApplications nodeKernel - dmqConfig - dmqDiffusionConfiguration - dmqLimitsAndTimeouts - dmqNtNApps - dmqNtCApps - (policy policyRng) - - Diffusion.run dmqDiffusionArguments - (dmqDiffusionTracers dmqConfig tracer) - dmqDiffusionConfiguration - dmqDiffusionApplications + Diffusion.withIOManager \iocp -> do + let localSnocket' = localSnocket iocp + mkStakePoolMonitor = connectToCardanoNode tracer localSnocket' snocketPath + + withNodeKernel @StandardCrypto + tracer + dmqConfig + evolutionConfig + psRng + mkStakePoolMonitor $ \nodeKernel -> do + dmqDiffusionConfiguration <- mkDiffusionConfiguration dmqConfig nt + + let sigSize :: Sig StandardCrypto -> SizeInBytes + sigSize _ = 0 -- TODO + mempoolReader = Mempool.getReader sigId sigSize (mempool nodeKernel) + dmqNtNApps = + let ntnMempoolWriter = Mempool.writerAdapter $ + Mempool.getWriter sigId + (poolValidationCtx $ stakePools nodeKernel) + (validateSig (hashKey . VKey)) + SigDuplicate + (mempool nodeKernel) + in ntnApps tracer + dmqConfig + mempoolReader + ntnMempoolWriter + sigSize + nodeKernel + (dmqCodecs + -- TODO: `maxBound :: Cardano.Network.NodeToNode.NodeToNodeVersion` + -- is unsafe here! + (encodeRemoteAddress (maxBound @NodeToNodeVersion)) + (decodeRemoteAddress (maxBound @NodeToNodeVersion))) + dmqLimitsAndTimeouts + defaultSigDecisionPolicy + dmqNtCApps = + let maxMsgs = 1000 -- TODO: make this negotiated in the handshake? + ntcMempoolWriter = + Mempool.getWriter sigId + (poolValidationCtx $ stakePools nodeKernel) + (validateSig (hashKey . VKey)) + SigDuplicate + (mempool nodeKernel) + in NtC.ntcApps tracer dmqConfig + mempoolReader ntcMempoolWriter maxMsgs + (NtC.dmqCodecs encodeReject decodeReject) + dmqDiffusionArguments = + diffusionArguments (if handshakeTracer + then WithEventType "Handshake" >$< tracer + else nullTracer) + (if localHandshakeTracer + then WithEventType "Handshake" >$< tracer + else nullTracer) + $ readTVar $ nodeKernel.stakePools.ledgerPeersVar + dmqDiffusionApplications = + diffusionApplications nodeKernel + dmqConfig + dmqDiffusionConfiguration + dmqLimitsAndTimeouts + dmqNtNApps + dmqNtCApps + (policy policyRng) + + Diffusion.run dmqDiffusionArguments + (dmqDiffusionTracers dmqConfig tracer) + dmqDiffusionConfiguration + dmqDiffusionApplications diff --git a/dmq-node/cddl/specs/sig.cddl b/dmq-node/cddl/specs/sig.cddl index 994bfda841f..10740d1a0ec 100644 --- a/dmq-node/cddl/specs/sig.cddl +++ b/dmq-node/cddl/specs/sig.cddl @@ -13,7 +13,7 @@ messagePayload = [ messageId = bstr messageBody = bstr -kesSignature = bstr +kesSignature = bstr .size 448 kesPeriod = word64 operationalCertificate = [ bstr .size 32, word64, word64, bstr .size 64 ] coldVerificationKey = bstr .size 32 diff --git a/dmq-node/changelog.d/20251016_142205_coot_dmq_signature_validation.md b/dmq-node/changelog.d/20251016_142205_coot_dmq_signature_validation.md new file mode 100644 index 00000000000..a32740c07e3 --- /dev/null +++ b/dmq-node/changelog.d/20251016_142205_coot_dmq_signature_validation.md @@ -0,0 +1,20 @@ + + +### Breaking + +- Using `KESPeriod` from `Cardano.Crypto.KES` instead of `SigKESPeriod` + newtype. `KESPeriod` is used by `SigRaw` data type. +- `SigKESSignature` holds `SigKES (KES crypto)` instead of a `ByteString`. +- `SigColdKey` holds `VerKeyDSIGN` instead of a `ByteString`. +- `ntnApps` constraints changed in order to use `sigValidate` function. + +### Non-Breaking + +- `Sig` codec decodes KES signatures, and the cold key. +- Added `DMQ.SigSubmission.Type.validateSig` and `SigValidationError`. + diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index 42cf76e6d8a..a94db0c1ea5 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -20,10 +20,15 @@ extra-doc-files: CHANGELOG.md flag cddl description: Enable CDDL based tests of the CBOR encoding - manual: True -- These tests need the cddl and the cbor-diag Ruby-package default: True +flag standardcrypto-tests + description: Enable StandardCrypto tests + -- these tests are flaky on GH Windows instances + manual: True + default: True + common extensions default-extensions: BangPatterns @@ -63,6 +68,7 @@ library DMQ.NodeToClient DMQ.NodeToClient.LocalMsgNotification DMQ.NodeToClient.LocalMsgSubmission + DMQ.NodeToClient.LocalStateQueryClient DMQ.NodeToClient.Version DMQ.NodeToNode DMQ.NodeToNode.Version @@ -76,6 +82,7 @@ library DMQ.Protocol.LocalMsgSubmission.Type DMQ.Protocol.SigSubmission.Codec DMQ.Protocol.SigSubmission.Type + DMQ.Protocol.SigSubmission.Validate DMQ.Tracer build-depends: @@ -88,6 +95,11 @@ library bytestring >=0.10 && <0.13, cardano-binary, cardano-crypto-class, + cardano-crypto-wrapper, + cardano-ledger-byron, + cardano-ledger-core, + cardano-ledger-shelley, + cardano-slotting, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.8, contra-tracer >=0.1 && <0.3, @@ -103,11 +115,17 @@ library network ^>=3.2.7, network-mux ^>=0.9.1, optparse-applicative ^>=0.18, + ouroboros-consensus, + ouroboros-consensus-cardano, + ouroboros-consensus-diffusion, + cardano-diffusion, ouroboros-network:{ouroboros-network, api, framework, orphan-instances, protocols} ^>=0.23, random ^>=1.2, singletons, text >=1.2.4 && <2.2, time ^>=1.12, + transformers, + transformers-except, typed-protocols:{typed-protocols, cborg} ^>=1.1, hs-source-dirs: src @@ -130,11 +148,13 @@ executable dmq-node aeson, base, cardano-git-rev, + cardano-ledger-core, contra-tracer >=0.1 && <0.3, dmq-node, + io-classes:{strict-stm}, kes-agent-crypto, optparse-applicative, - ouroboros-network:{ouroboros-network, api}, + ouroboros-network:{ouroboros-network, api, framework}, random, text, @@ -186,6 +206,9 @@ test-suite dmq-tests -T -RTS + if flag(standardcrypto-tests) + cpp-options: -DSTANDARDCRYPTO_TESTS + test-suite dmq-cddl import: warnings, diff --git a/dmq-node/src/DMQ/Configuration.hs b/dmq-node/src/DMQ/Configuration.hs index d3b9c8c69aa..fd436785a4c 100644 --- a/dmq-node/src/DMQ/Configuration.hs +++ b/dmq-node/src/DMQ/Configuration.hs @@ -90,6 +90,10 @@ data Configuration' f = dmqcPortNumber :: f PortNumber, dmqcConfigFile :: f FilePath, dmqcTopologyFile :: f FilePath, + dmqcShelleyGenesisFile :: f FilePath, + -- ^ shelley genesis file, e.g. + -- `/configuration/cardano/mainnet-shelley-genesis.json` in `cardano-node` + -- repo. dmqcAcceptedConnectionsLimit :: f AcceptedConnectionsLimit, dmqcDiffusionMode :: f DiffusionMode, dmqcTargetOfRootPeers :: f Int, @@ -103,6 +107,7 @@ data Configuration' f = dmqcChurnInterval :: f DiffTime, dmqcPeerSharing :: f PeerSharing, dmqcNetworkMagic :: f NetworkMagic, + dmqcCardanoNodeSocket :: f FilePath, dmqcPrettyLog :: f Bool, dmqcMuxTracer :: f Bool, @@ -210,8 +215,10 @@ defaultConfiguration = Configuration { dmqcPortNumber = I 3_141, dmqcConfigFile = I "dmq.configuration.yaml", dmqcTopologyFile = I "dmq.topology.json", + dmqcShelleyGenesisFile = I "mainnet-shelley-genesis.json", dmqcAcceptedConnectionsLimit = I defaultAcceptedConnectionsLimit, dmqcDiffusionMode = I InitiatorAndResponderDiffusionMode, + dmqcCardanoNodeSocket = I "cardano-node.socket", dmqcTargetOfRootPeers = I targetNumberOfRootPeers, dmqcTargetOfKnownPeers = I targetNumberOfKnownPeers, dmqcTargetOfEstablishedPeers = I targetNumberOfEstablishedPeers, @@ -299,6 +306,9 @@ instance FromJSON PartialConfig where dmqcNetworkMagic <- Last . fmap NetworkMagic <$> v .:? "NetworkMagic" dmqcDiffusionMode <- Last <$> v .:? "DiffusionMode" dmqcPeerSharing <- Last <$> v .:? "PeerSharing" + dmqcCardanoNodeSocket <- Last <$> v .:? "CardanoNodeSocket" + + dmqcShelleyGenesisFile <- Last <$> v .:? "ShelleyGenesisFile" dmqcTargetOfRootPeers <- Last <$> v .:? "TargetNumberOfRootPeers" dmqcTargetOfKnownPeers <- Last <$> v .:? "TargetNumberOfKnownPeers" @@ -375,7 +385,9 @@ instance ToJSON Configuration where , "PortNumber" .= unI dmqcPortNumber , "LocalAddress" .= unI dmqcLocalAddress , "ConfigFile" .= unI dmqcConfigFile + , "CardanoNodeSocket" .= unI dmqcCardanoNodeSocket , "TopologyFile" .= unI dmqcTopologyFile + , "ShelleyGenesisFile" .= unI dmqcShelleyGenesisFile , "AcceptedConnectionsLimit" .= unI dmqcAcceptedConnectionsLimit , "DiffusionMode" .= unI dmqcDiffusionMode , "TargetOfRootPeers" .= unI dmqcTargetOfRootPeers @@ -604,5 +616,3 @@ data ConfigurationError = instance Exception ConfigurationError where displayException NoAddressInformation = "no ipv4 or ipv6 address specified, use --host-addr or --host-ipv6-addr" - - diff --git a/dmq-node/src/DMQ/Configuration/CLIOptions.hs b/dmq-node/src/DMQ/Configuration/CLIOptions.hs index e59a62ef278..decc8fed134 100644 --- a/dmq-node/src/DMQ/Configuration/CLIOptions.hs +++ b/dmq-node/src/DMQ/Configuration/CLIOptions.hs @@ -53,6 +53,13 @@ parseCLIOptions = <> help "Topology file for DMQ Node" ) ) + <*> optional ( + strOption + ( long "cardano-node-socket" + <> metavar "Cardano node socket path" + <> help "Used for local connections to Cardano node" + ) + ) <*> optional ( switch ( long "version" @@ -61,14 +68,14 @@ parseCLIOptions = ) ) where - mkConfiguration ipv4 ipv6 portNumber localAddress configFile topologyFile version = - mempty { dmqcIPv4 = Last (Just <$> ipv4), - dmqcIPv6 = Last (Just <$> ipv6), - dmqcLocalAddress = Last (LocalAddress <$> localAddress), - dmqcPortNumber = Last portNumber, - dmqcConfigFile = Last configFile, - dmqcTopologyFile = Last topologyFile, - dmqcVersion = Last version + mkConfiguration ipv4 ipv6 portNumber localAddress + configFile topologyFile cardanoNodeSocket version = + mempty { dmqcIPv4 = Last (Just <$> ipv4), + dmqcIPv6 = Last (Just <$> ipv6), + dmqcLocalAddress = Last (LocalAddress <$> localAddress), + dmqcPortNumber = Last portNumber, + dmqcConfigFile = Last configFile, + dmqcTopologyFile = Last topologyFile, + dmqcCardanoNodeSocket = Last cardanoNodeSocket, + dmqcVersion = Last version } - - diff --git a/dmq-node/src/DMQ/Diffusion/Arguments.hs b/dmq-node/src/DMQ/Diffusion/Arguments.hs index 20c882c45b3..a00ea723a8b 100644 --- a/dmq-node/src/DMQ/Diffusion/Arguments.hs +++ b/dmq-node/src/DMQ/Diffusion/Arguments.hs @@ -22,6 +22,7 @@ import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadCatch) import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer) import Control.Tracer (Tracer) +import Data.List.NonEmpty (NonEmpty) import Network.DNS (Resolver) import Network.Socket (Socket) @@ -35,7 +36,7 @@ import Ouroboros.Network.PeerSelection.Churn (peerChurnGovernor) import Ouroboros.Network.PeerSelection.Governor.Types (ExtraGuardedDecisions (..), PeerSelectionGovernorArgs (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeersConsensusInterface (..)) + (LedgerPeersConsensusInterface (..), PoolStake, LedgerRelayAccessPoint) import Ouroboros.Network.PeerSelection.RelayAccessPoint (SRVPrefix) import Ouroboros.Network.PeerSelection.Types (nullPublicExtraPeersAPI) @@ -49,6 +50,7 @@ diffusionArguments ) => Tracer m (NtN.HandshakeTr ntnAddr) -> Tracer m (NtC.HandshakeTr ntcAddr) + -> STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)] -> Diffusion.Arguments NoExtraState NoExtraDebugState NoExtraFlags NoExtraPeers NoExtraAPI NoExtraChurnArgs NoExtraCounters NoExtraTracer @@ -63,7 +65,8 @@ diffusionArguments NodeToClientVersion NodeToClientVersionData diffusionArguments handshakeNtNTracer - handshakeNtCTracer = + handshakeNtCTracer + lpGetLedgerPeers = Diffusion.Arguments { Diffusion.daNtnDataFlow = DMQ.ntnDataFlow , Diffusion.daNtnPeerSharing = peerSharing @@ -74,7 +77,7 @@ diffusionArguments handshakeNtNTracer , Diffusion.daLedgerPeersCtx = LedgerPeersConsensusInterface { lpGetLatestSlot = return minBound - , lpGetLedgerPeers = return [] + , lpGetLedgerPeers , lpExtraAPI = NoExtraAPI } , Diffusion.daEmptyExtraState = NoExtraState diff --git a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs index da282e989a6..0239110d7f7 100644 --- a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs +++ b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} module DMQ.Diffusion.NodeKernel ( NodeKernel (..) , withNodeKernel + , PoolValidationCtx (..) + , StakePools (..) ) where import Control.Concurrent.Class.MonadMVar @@ -19,29 +20,41 @@ import Data.Aeson qualified as Aeson import Data.Function (on) import Data.Functor.Contravariant ((>$<)) import Data.Hashable +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +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 System.Random (StdGen) import System.Random qualified as Random +import Cardano.Ledger.Shelley.API hiding (I) import Cardano.KESAgent.KES.Crypto (Crypto (..)) +import Cardano.KESAgent.KES.Evolution qualified as KES +import Ouroboros.Consensus.Shelley.Ledger.Query import Ouroboros.Network.BlockFetch (FetchClientRegistry, newFetchClientRegistry) import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.PeerSelection.Governor.Types (makePublicPeerSelectionStateVar) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (PoolStake, + LedgerRelayAccessPoint) import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry, newPeerSharingAPI, newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME) import Ouroboros.Network.TxSubmission.Inbound.V2 -import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool (..)) +import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool (..), + MempoolSeq (..)) import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool import DMQ.Configuration -import DMQ.Protocol.SigSubmission.Type (Sig (sigExpiresAt), SigId) +import DMQ.Protocol.SigSubmission.Type (Sig (sigExpiresAt, sigId), SigId) import DMQ.Tracer @@ -54,19 +67,43 @@ data NodeKernel crypto ntnAddr m = -- the PeerSharing protocol , peerSharingRegistry :: !(PeerSharingRegistry ntnAddr m) , peerSharingAPI :: !(PeerSharingAPI ntnAddr StdGen m) - , mempool :: !(Mempool m (Sig crypto)) + , mempool :: !(Mempool m SigId (Sig crypto)) + , evolutionConfig :: !(KES.EvolutionConfig) , 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 = KeyHash StakePool + +data StakePools m = StakePools { + -- | contains map of cardano pool stake snapshot obtained + -- via local state query client + stakePoolsVar :: StrictTVar m (Map PoolId StakeSnapshot) + -- | acquires validation context for signature validation + , poolValidationCtx :: m PoolValidationCtx + , ledgerPeersVar + :: StrictTVar m [(PoolStake, NonEmpty LedgerRelayAccessPoint)] + } + +data PoolValidationCtx = + DMQPoolValidationCtx !UTCTime -- ^ time of context acquisition + !(Maybe UTCTime) -- ^ UTC time of next epoch boundary + !(Map PoolId StakeSnapshot) -- ^ for signature validation + newNodeKernel :: ( MonadLabelledSTM m , MonadMVar m + , MonadTime m , Ord ntnAddr ) - => StdGen + => KES.EvolutionConfig + -> StdGen -> m (NodeKernel crypto ntnAddr m) -newNodeKernel rng = do +newNodeKernel evolutionConfig rng = do publicPeerSelectionStateVar <- makePublicPeerSelectionStateVar fetchClientRegistry <- newFetchClientRegistry @@ -77,6 +114,15 @@ newNodeKernel rng = do sigMempoolSem <- newTxMempoolSem let (rng', rng'') = Random.split rng sigSharedTxStateVar <- newSharedTxStateVar rng' + (nextEpochVar, stakePoolsVar, ledgerPeersVar) <- atomically $ + (,,) <$> newTVar Nothing <*> newTVar Map.empty <*> newTVar [] + let poolValidationCtx = do + (nextEpochBoundary, stakePools') <- + atomically $ (,) <$> readTVar nextEpochVar <*> readTVar stakePoolsVar + now <- getCurrentTime + return $ DMQPoolValidationCtx now nextEpochBoundary stakePools' + + stakePools = StakePools { stakePoolsVar, poolValidationCtx, ledgerPeersVar } peerSharingAPI <- newPeerSharingAPI @@ -89,9 +135,12 @@ newNodeKernel rng = do , peerSharingRegistry , peerSharingAPI , mempool + , evolutionConfig , sigChannelVar , sigMempoolSem , sigSharedTxStateVar + , nextEpochVar + , stakePools } @@ -110,7 +159,9 @@ withNodeKernel :: forall crypto ntnAddr m a. ) => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) -> Configuration + -> KES.EvolutionConfig -> StdGen + -> (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 @@ -119,12 +170,14 @@ withNodeKernel tracer Configuration { dmqcSigSubmissionLogicTracer = I sigSubmissionLogicTracer } - rng k = do + evolutionConfig + rng + mkStakePoolMonitor k = do nodeKernel@NodeKernel { mempool, sigChannelVar, sigSharedTxStateVar } - <- newNodeKernel rng + <- newNodeKernel evolutionConfig rng withAsync (mempoolWorker mempool) $ \mempoolThread -> withAsync (decisionLogicThreads @@ -135,10 +188,12 @@ withNodeKernel tracer defaultSigDecisionPolicy sigChannelVar sigSharedTxStateVar) - $ \sigLogicThread - -> link mempoolThread - >> link sigLogicThread - >> k nodeKernel + $ \sigLogicThread -> + withAsync (mkStakePoolMonitor nodeKernel) \spmAid -> do + link mempoolThread + link sigLogicThread + link spmAid + k nodeKernel mempoolWorker :: forall crypto m. @@ -146,22 +201,36 @@ mempoolWorker :: forall crypto m. , MonadSTM m , MonadTime m ) - => Mempool m (Sig crypto) + => Mempool m SigId (Sig crypto) -> m Void mempoolWorker (Mempool v) = loop where loop = do now <- getCurrentPOSIXTime rt <- atomically $ do - (sigs :: Seq.Seq (Sig crypto)) <- readTVar v - let sigs' :: Seq.Seq (Sig crypto) - (resumeTime, sigs') = - foldr (\a (rt, as) -> if sigExpiresAt a <= now - then (rt, as) - else (rt `min` sigExpiresAt a, a Seq.<| as)) - (now, Seq.empty) - sigs - writeTVar v sigs' + MempoolSeq { mempoolSeq, mempoolSet } <- readTVar v + let mempoolSeq' :: Seq (Sig crypto) + mempoolSet', expiredSet' :: Set SigId + + (resumeTime, expiredSet', mempoolSeq') = + foldr (\sig (rt, expiredSet, sigs) -> + if sigExpiresAt sig <= now + then ( rt + , sigId sig `Set.insert` expiredSet + , sigs + ) + else ( rt `min` sigExpiresAt sig + , expiredSet + , sig Seq.<| sigs + ) + ) + (now, Set.empty, Seq.empty) + mempoolSeq + + mempoolSet' = mempoolSet `Set.difference` expiredSet' + + writeTVar v MempoolSeq { mempoolSet = mempoolSet', + mempoolSeq = mempoolSeq' } return resumeTime now' <- getCurrentPOSIXTime diff --git a/dmq-node/src/DMQ/NodeToClient.hs b/dmq-node/src/DMQ/NodeToClient.hs index a6684db27d5..5a129c33388 100644 --- a/dmq-node/src/DMQ/NodeToClient.hs +++ b/dmq-node/src/DMQ/NodeToClient.hs @@ -16,7 +16,7 @@ module DMQ.NodeToClient import Data.Aeson qualified as Aeson import Data.ByteString.Lazy (ByteString) import Data.Functor.Contravariant ((>$<)) -import Data.Typeable (Typeable) +import Data.Typeable import Data.Void import Data.Word @@ -47,6 +47,7 @@ import DMQ.Protocol.LocalMsgSubmission.Codec import DMQ.Protocol.LocalMsgSubmission.Server import DMQ.Protocol.LocalMsgSubmission.Type import DMQ.Protocol.SigSubmission.Type (Sig, SigId, sigId) +import DMQ.Protocol.SigSubmission.Validate import DMQ.Tracer import Ouroboros.Network.Context @@ -58,9 +59,9 @@ import Ouroboros.Network.OrphanInstances () import Ouroboros.Network.Protocol.Handshake (Handshake, HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, codecHandshake, noTimeLimitsHandshake) -import Ouroboros.Network.TxSubmission.Inbound.V2.Types - (TxSubmissionMempoolWriter) import Ouroboros.Network.TxSubmission.Mempool.Reader +import Ouroboros.Network.TxSubmission.Mempool.Simple +import Ouroboros.Network.Util.ShowProxy type HandshakeTr ntcAddr = Mx.WithBearer (ConnectionId ntcAddr) (TraceSendRecv (Handshake NodeToClientVersion CBOR.Term)) @@ -100,8 +101,8 @@ data Codecs crypto m = dmqCodecs :: ( MonadST m , Crypto crypto ) - => (SigMempoolFail -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s SigMempoolFail) + => (MempoolAddFail (Sig crypto) -> CBOR.Encoding) + -> (forall s. CBOR.Decoder s (MempoolAddFail (Sig crypto))) -> Codecs crypto m dmqCodecs encodeReject' decodeReject' = Codecs { @@ -137,13 +138,17 @@ ntcApps , MonadThread m , MonadSTM m , Crypto crypto - , Typeable crypto , Aeson.ToJSON ntcAddr + , Aeson.ToJSON (MempoolAddFail (Sig crypto)) + , Show (MempoolAddFail (Sig crypto)) + , ShowProxy (MempoolAddFail (Sig crypto)) + , ShowProxy (Sig crypto) + , Typeable crypto ) => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) -> Configuration -> TxSubmissionMempoolReader SigId (Sig crypto) idx m - -> TxSubmissionMempoolWriter SigId (Sig crypto) idx m + -> MempoolWriter SigId (Sig crypto) idx m -> Word16 -> Codecs crypto m -> Apps ntcAddr m () diff --git a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs index 152ed979c1b..36a7eb418df 100644 --- a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs +++ b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs @@ -1,55 +1,84 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} module DMQ.NodeToClient.LocalMsgSubmission where import Control.Concurrent.Class.MonadSTM +import Control.Monad.Class.MonadThrow import Control.Tracer import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson qualified as Aeson -import Data.Maybe - -import Ouroboros.Network.TxSubmission.Inbound.V2 +import Data.Typeable import DMQ.Protocol.LocalMsgSubmission.Server import DMQ.Protocol.LocalMsgSubmission.Type +import Ouroboros.Network.TxSubmission.Mempool.Simple -- | Local transaction submission server, for adding txs to the 'Mempool' -- localMsgSubmissionServer :: - MonadSTM m + forall msgid msg idx m. + ( MonadSTM m + , MonadThrow m + , Typeable msgid + , Typeable msg + , Show msgid + , Show (MempoolAddFail msg)) => (msg -> msgid) -- ^ get message id - -> Tracer m (TraceLocalMsgSubmission msgid) - -> TxSubmissionMempoolWriter msgid msg idx m + -> Tracer m (TraceLocalMsgSubmission msg msgid) + -> MempoolWriter msgid msg idx m + -- ^ duplicate error tag in case the mempool returns the empty list on failure -> m (LocalMsgSubmissionServer msg m ()) -localMsgSubmissionServer getMsgId tracer TxSubmissionMempoolWriter { mempoolAddTxs } = +localMsgSubmissionServer getMsgId tracer MempoolWriter { mempoolAddTxs } = pure server where - failure = - -- TODO remove dummy hardcode when mempool returns reason - (SubmitFail SigExpired, server) <$ traceWith tracer (TraceSubmitFailure SigExpired) - success msgid = + process (Left (msgid, reason)) = do + traceWith tracer (TraceSubmitFailure msgid reason) + throwIO $ MsgValidationException msgid reason + process (Right [(msgid, e@(SubmitFail reason))]) = + (e, server) <$ traceWith tracer (TraceSubmitFailure msgid reason) + process (Right [(msgid, SubmitSuccess)]) = (SubmitSuccess, server) <$ traceWith tracer (TraceSubmitAccept msgid) + process _ = throwIO (TooManyMessages @msgid @msg) server = LocalTxSubmissionServer { recvMsgSubmitTx = \msg -> do traceWith tracer $ TraceReceivedMsg (getMsgId msg) - -- TODO mempool should return 'SubmitResult' - maybe failure success . listToMaybe =<< mempoolAddTxs [msg] + process =<< mempoolAddTxs [msg] , recvMsgDone = () } -data TraceLocalMsgSubmission msgid = +data TraceLocalMsgSubmission msg msgid = TraceReceivedMsg msgid - -- ^ A transaction was received. - | TraceSubmitFailure SigMempoolFail + -- ^ A signature was received. + | TraceSubmitFailure msgid (MempoolAddFail msg) | TraceSubmitAccept msgid - deriving Show -instance ToJSON msgid - => ToJSON (TraceLocalMsgSubmission msgid) where +deriving instance + (Show msg, Show msgid, Show (MempoolAddFail msg)) + => Show (TraceLocalMsgSubmission msg msgid) + + + +data MsgSubmissionServerException msgid msg = + MsgValidationException msgid (MempoolAddFail msg) + | TooManyMessages + +deriving instance (Show (MempoolAddFail msg), Show msgid) + => Show (MsgSubmissionServerException msgid msg) + +instance (Typeable msgid, Typeable msg, Show (MempoolAddFail msg), Show msgid) + => Exception (MsgSubmissionServerException msgid msg) where + + +instance (ToJSON msgid, ToJSON (MempoolAddFail msg)) + => ToJSON (TraceLocalMsgSubmission msg msgid) where toJSON (TraceReceivedMsg msgid) = -- TODO: once we have verbosity levels, we could include the full tx, for -- now one can use `TraceSendRecv` tracer for the mini-protocol to see full @@ -57,8 +86,9 @@ instance ToJSON msgid object [ "kind" .= Aeson.String "TraceReceivedMsg" , "sigId" .= msgid ] - toJSON (TraceSubmitFailure reject) = + toJSON (TraceSubmitFailure msgid reject) = object [ "kind" .= Aeson.String "TraceSubmitFailure" + , "sigId" .= msgid , "reason" .= reject ] toJSON (TraceSubmitAccept msgid) = diff --git a/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs b/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs new file mode 100644 index 00000000000..4cb81178bce --- /dev/null +++ b/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE TypeOperators #-} + +module DMQ.NodeToClient.LocalStateQueryClient + ( cardanoClient + , connectToCardanoNode + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +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) +import Data.Functor.Contravariant ((>$<)) +import Data.Map.Strict qualified as Map +import Data.Proxy +import Data.Void + +import Cardano.Chain.Genesis +import Cardano.Chain.Slotting +import Cardano.Crypto.ProtocolMagic +import Cardano.Network.NodeToClient +import Cardano.Slotting.EpochInfo.API +import Cardano.Slotting.Time +import DMQ.Diffusion.NodeKernel +import DMQ.Tracer +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Cardano.Node +import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query +import Ouroboros.Consensus.HardFork.History.EpochInfo +import Ouroboros.Consensus.Ledger.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.Type (LedgerPeerSnapshot (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Client +import Ouroboros.Network.Protocol.LocalStateQuery.Type + +-- 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) + => Tracer m String -- TODO: replace string with a proper type + -> StakePools m + -> StrictTVar m (Maybe UTCTime) -- ^ from node kernel + -> LocalStateQueryClient (CardanoBlock crypto) (Point block) (Query block) m Void +cardanoClient _tracer StakePools { stakePoolsVar, ledgerPeersVar } nextEpochVar = + LocalStateQueryClient (idle Nothing) + where + idle mSystemStart = pure $ SendMsgAcquire ImmutableTip acquire + where + acquire :: ClientStAcquiring block point query m Void + acquire = ClientStAcquiring { + recvMsgAcquired = + let epochQry systemStart = pure $ + SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetEpochNo) + $ wrappingMismatch (handleEpoch systemStart) + in case mSystemStart of + Just systemStart -> epochQry systemStart + Nothing -> pure $ + SendMsgQuery GetSystemStart $ ClientStQuerying epochQry + + , recvMsgFailure = \failure -> + throwIO . userError $ "recvMsgFailure: " <> show failure + } + + wrappingMismatch k = ClientStQuerying $ + either (const . throwIO . userError $ "mismatch era info") k + + handleEpoch systemStart epoch = pure + . SendMsgQuery (BlockQuery . QueryHardFork $ GetInterpreter) + $ getInterpreter systemStart epoch + + getInterpreter systemStart epoch = ClientStQuerying \interpreter -> do + let ei = interpreterToEpochInfo interpreter + res = + runExcept do + lastSlot <- snd <$> epochInfoRange ei epoch + lastSlotTime <- epochInfoSlotToRelativeTime ei lastSlot + lastSlotLength <- epochInfoSlotLength ei lastSlot + pure $ addRelativeTime (getSlotLength lastSlotLength) lastSlotTime + + case res of + Left _err -> pure $ SendMsgRelease do + threadDelay 86400 -- TODO fuzz this? + idle $ Just systemStart + Right relativeTime -> do + now <- getCurrentTime + let nextEpoch = fromRelativeTime systemStart relativeTime + toNextEpoch = diffUTCTime nextEpoch now + pure $ + SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetStakeSnapshots Nothing) + $ wrappingMismatch (handleStakeSnapshots systemStart nextEpoch toNextEpoch) + + handleStakeSnapshots systemStart nextEpoch toNextEpoch StakeSnapshots { ssStakeSnapshots } = do + atomically do + writeTVar stakePoolsVar ssStakeSnapshots + writeTVar nextEpochVar $ Just nextEpoch + pure $ + SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetBigLedgerPeerSnapshot) + $ wrappingMismatch handleLedgerPeers + where + handleLedgerPeers (LedgerPeerSnapshot snapshot) = do + let bigRelays = fmap snd . snd $ snapshot + atomically do + writeTVar ledgerPeersVar bigRelays + pure $ SendMsgRelease do + threadDelay $ min (realToFrac toNextEpoch) 86400 -- TODO fuzz this? + idle $ Just systemStart + + +connectToCardanoNode :: Tracer IO (WithEventType String) + -> LocalSnocket + -> FilePath + -> NodeKernel crypto ntnAddr IO + -> IO (Either SomeException Void) +connectToCardanoNode tracer localSnocket' snocketPath nodeKernel = + connectTo + localSnocket' + nullNetworkConnectTracers --debuggingNetworkConnectTracers + (combineVersions + [ simpleSingletonVersions + version + NodeToClientVersionData { + networkMagic = + NetworkMagic -- 2 {- preview net -} + . unProtocolMagicId + $ mainnetProtocolMagicId + , 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 + , cStateQueryCodec + , StateIdle + , localStateQueryClientPeer + $ cardanoClient (WithEventType "LocalStateQuery" >$< 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 diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs index 9ff7a3acc7c..982e5255027 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module DMQ.NodeToNode ( RemoteAddress @@ -40,6 +41,7 @@ import Codec.CBOR.Encoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Term qualified as CBOR import Data.Aeson qualified as Aeson +import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL import Data.Functor.Contravariant ((>$<)) import Data.Hashable (Hashable) @@ -52,7 +54,10 @@ import Network.Mux.Types (Mode (..)) import Network.Mux.Types qualified as Mx import Network.TypedProtocol.Codec (AnnotatedCodec, Codec) +import Cardano.Crypto.DSIGN.Class qualified as DSIGN +import Cardano.Crypto.KES.Class qualified as KES import Cardano.KESAgent.KES.Crypto (Crypto (..)) +import Cardano.KESAgent.KES.OCert (OCertSignable) import DMQ.Configuration (Configuration, Configuration' (..), I (..)) import DMQ.Diffusion.NodeKernel (NodeKernel (..)) @@ -85,7 +90,7 @@ import Ouroboros.Network.PeerSharing (bracketPeerSharingClient, peerSharingClient, peerSharingServer) import Ouroboros.Network.Snocket (RemoteAddress) import Ouroboros.Network.TxSubmission.Inbound.V2 as SigSubmission -import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool +import Ouroboros.Network.TxSubmission.Mempool.Reader import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.OrphanInstances () @@ -145,8 +150,12 @@ data Apps addr m a b = } ntnApps - :: forall crypto m addr . + :: forall crypto m addr idx. ( Crypto crypto + -- , DSIGN.ContextDSIGN (DSIGN crypto) ~ () + -- , DSIGN.Signable (DSIGN crypto) (OCertSignable crypto) + -- , KES.ContextKES (KES crypto) ~ () + -- , KES.Signable (KES crypto) BS.ByteString , Typeable crypto , Alternative (STM m) , MonadAsync m @@ -157,12 +166,16 @@ ntnApps , MonadThrow (STM m) , MonadTimer m , Ord addr + , Ord idx , Show addr , Hashable addr , Aeson.ToJSON addr ) => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) -> Configuration + -> TxSubmissionMempoolReader SigId (Sig crypto) idx m + -> TxSubmissionMempoolWriter SigId (Sig crypto) idx m + -> (Sig crypto -> SizeInBytes) -> NodeKernel crypto addr m -> Codecs crypto addr m -> LimitsAndTimeouts crypto addr @@ -182,11 +195,15 @@ ntnApps , dmqcSigSubmissionInboundTracer = I sigSubmissionInboundTracer , dmqcSigSubmissionLogicTracer = I sigSubmissionLogicTracer } + mempoolReader + mempoolWriter + sigSize NodeKernel { fetchClientRegistry , peerSharingRegistry , peerSharingAPI , mempool + , evolutionConfig , sigChannelVar , sigMempoolSem , sigSharedTxStateVar @@ -215,20 +232,6 @@ ntnApps , aPeerSharingServer } where - sigSize :: Sig crypto -> SizeInBytes - sigSize _ = 0 -- TODO - - mempoolReader = Mempool.getReader sigId sigSize mempool - -- TODO: invalid signatures are just omitted from the mempool. For DMQ - -- we need to validate signatures when we received them, and shutdown - -- connection if we receive one, rather than validate them in the - -- mempool. - mempoolWriter = Mempool.getWriter sigId - (pure ()) - (\_ _ -> Right () :: Either Void ()) - (\_ -> True) - mempool - aSigSubmissionClient :: NodeToNodeVersion -> ExpandedInitiatorContext addr m diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs index 01429e66b8b..dc23363faef 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs @@ -17,10 +17,11 @@ module DMQ.Protocol.LocalMsgSubmission.Client import DMQ.Protocol.LocalMsgSubmission.Type import Network.TypedProtocol.Peer.Client import Ouroboros.Network.Protocol.LocalTxSubmission.Client +import Ouroboros.Network.TxSubmission.Mempool.Simple -- | Type aliases for the high level client API -- -type LocalMsgSubmissionClient sig = LocalTxSubmissionClient sig SigMempoolFail +type LocalMsgSubmissionClient sig = LocalTxSubmissionClient sig (MempoolAddFail sig) type LocalMsgClientStIdle = LocalTxClientStIdle diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs index 8a010bff407..e6cf96e229d 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs @@ -10,13 +10,17 @@ import Codec.CBOR.Encoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR import Control.Monad.Class.MonadST import Data.ByteString.Lazy (ByteString) +import Data.Text qualified as T +import Data.Tuple (swap) import Text.Printf +import Cardano.Binary import Cardano.KESAgent.KES.Crypto (Crypto (..)) import DMQ.Protocol.LocalMsgSubmission.Type import DMQ.Protocol.SigSubmission.Codec qualified as SigSubmission import DMQ.Protocol.SigSubmission.Type (Sig (..)) +import DMQ.Protocol.SigSubmission.Validate import Network.TypedProtocol.Codec.CBOR import Ouroboros.Network.Protocol.LocalTxSubmission.Codec qualified as LTX @@ -26,26 +30,59 @@ codecLocalMsgSubmission ( MonadST m , Crypto crypto ) - => (SigMempoolFail -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s SigMempoolFail) + => (MempoolAddFail (Sig crypto) -> CBOR.Encoding) + -> (forall s. CBOR.Decoder s (MempoolAddFail (Sig crypto))) -> AnnotatedCodec (LocalMsgSubmission (Sig crypto)) CBOR.DeserialiseFailure m ByteString codecLocalMsgSubmission = LTX.anncodecLocalTxSubmission' SigWithBytes SigSubmission.encodeSig SigSubmission.decodeSig -encodeReject :: SigMempoolFail -> CBOR.Encoding +encodeReject :: MempoolAddFail (Sig crypto) -> CBOR.Encoding encodeReject = \case - SigInvalid reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> CBOR.encodeString reason + SigInvalid reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> e + where + e = case reason of + InvalidKESSignature ocertKESPeriod sigKESPeriod err -> mconcat [ + CBOR.encodeListLen 4, CBOR.encodeWord 0, toCBOR ocertKESPeriod, toCBOR sigKESPeriod, CBOR.encodeString (T.pack err) + ] + InvalidSignatureOCERT ocertN sigKESPeriod err -> mconcat [ + CBOR.encodeListLen 4, CBOR.encodeWord 1, CBOR.encodeWord64 ocertN, toCBOR sigKESPeriod, CBOR.encodeString (T.pack err) + ] + KESBeforeStartOCERT startKESPeriod sigKESPeriod -> mconcat [ + CBOR.encodeListLen 3, CBOR.encodeWord 2, toCBOR startKESPeriod, toCBOR sigKESPeriod + ] + KESAfterEndOCERT endKESPeriod sigKESPeriod -> mconcat [ + CBOR.encodeListLen 3, CBOR.encodeWord 3, toCBOR endKESPeriod, toCBOR sigKESPeriod + ] + UnrecognizedPool -> CBOR.encodeListLen 1 <> CBOR.encodeWord 4 + ExpiredPool -> CBOR.encodeListLen 1 <> CBOR.encodeWord 5 + NotInitialized -> CBOR.encodeListLen 1 <> CBOR.encodeWord 6 + ClockSkew -> CBOR.encodeListLen 1 <> CBOR.encodeWord 7 SigDuplicate -> CBOR.encodeListLen 1 <> CBOR.encodeWord 1 SigExpired -> CBOR.encodeListLen 1 <> CBOR.encodeWord 2 SigResultOther reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord 3 <> CBOR.encodeString reason -decodeReject :: CBOR.Decoder s SigMempoolFail +decodeReject :: CBOR.Decoder s (MempoolAddFail (Sig crypto)) decodeReject = do len <- CBOR.decodeListLen tag <- CBOR.decodeWord case (tag, len) of - (0, 2) -> SigInvalid <$> CBOR.decodeString + (0, 2) -> SigInvalid <$> decSigValidError + where + decSigValidError :: CBOR.Decoder s SigValidationError + decSigValidError = do + lenTag <- (,) <$> CBOR.decodeListLen <*> CBOR.decodeWord + case swap lenTag of + (0, 4) -> InvalidKESSignature <$> fromCBOR <*> fromCBOR <*> (T.unpack <$> CBOR.decodeString) + (1, 4) -> InvalidSignatureOCERT <$> CBOR.decodeWord64 <*> fromCBOR <*> (T.unpack <$> CBOR.decodeString) + (2, 3) -> KESBeforeStartOCERT <$> fromCBOR <*> fromCBOR + (3, 4) -> KESAfterEndOCERT <$> fromCBOR <*> fromCBOR + (4, 1) -> pure UnrecognizedPool + (5, 1) -> pure ExpiredPool + (6, 1) -> pure NotInitialized + (7, 1) -> pure ClockSkew + _otherwise -> fail $ printf "unrecognized (tag,len) = (%d, %d) when decoding SigInvalid tag" tag len + (1, 1) -> pure SigDuplicate (2, 1) -> pure SigExpired (3, 2) -> SigResultOther <$> CBOR.decodeString diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs index 9a44d2b0060..7936fd78945 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs @@ -18,10 +18,11 @@ module DMQ.Protocol.LocalMsgSubmission.Server import DMQ.Protocol.LocalMsgSubmission.Type import Network.TypedProtocol.Peer.Server import Ouroboros.Network.Protocol.LocalTxSubmission.Server as LocalTxSubmission +import Ouroboros.Network.TxSubmission.Mempool.Simple -- | Type aliases for the high level client API -- -type LocalMsgSubmissionServer sig = LocalTxSubmissionServer sig SigMempoolFail +type LocalMsgSubmissionServer sig = LocalTxSubmissionServer sig (MempoolAddFail sig) -- | A non-pipelined 'Peer' representing the 'LocalMsgSubmissionServer'. diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs index 2ef26424b9f..114249c8f31 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs @@ -13,35 +13,10 @@ module DMQ.Protocol.LocalMsgSubmission.Type , module Ouroboros ) where -import Data.Aeson -import Data.Text (Text) import Network.TypedProtocol.Core as Core import Ouroboros.Network.Protocol.LocalTxSubmission.Type as Ouroboros -import Ouroboros.Network.Util.ShowProxy +import Ouroboros.Network.TxSubmission.Mempool.Simple -- | The LocalMsgSubmission protocol is an alias for the LocalTxSubmission -- -type LocalMsgSubmission sig = Ouroboros.LocalTxSubmission sig SigMempoolFail - --- | The type of failures when adding to the mempool --- -data SigMempoolFail = - SigInvalid Text - | SigDuplicate - | SigExpired - | SigResultOther Text - deriving (Eq, Show) - -instance ShowProxy SigMempoolFail where - -instance ToJSON SigMempoolFail where - toJSON SigDuplicate = String "duplicate" - toJSON SigExpired = String "expired" - toJSON (SigInvalid txt) = object - [ "type" .= String "invalid" - , "reason" .= txt - ] - toJSON (SigResultOther txt) = object - [ "type" .= String "other" - , "reason" .= txt - ] +type LocalMsgSubmission sig = Ouroboros.LocalTxSubmission sig (MempoolAddFail sig) diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs index b45ee5f702f..aa09d119152 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -33,8 +32,9 @@ import Codec.CBOR.Read qualified as CBOR import Network.TypedProtocol.Codec.CBOR import Cardano.Binary (FromCBOR (..), ToCBOR (..)) -import Cardano.Crypto.DSIGN.Class (decodeSignedDSIGN, encodeSignedDSIGN) -import Cardano.Crypto.KES.Class (decodeVerKeyKES, encodeVerKeyKES) +import Cardano.Crypto.DSIGN.Class (decodeSignedDSIGN, decodeVerKeyDSIGN, + encodeSignedDSIGN) +import Cardano.Crypto.KES.Class (decodeSigKES, decodeVerKeyKES, encodeVerKeyKES) import Cardano.KESAgent.KES.Crypto (Crypto (..)) import Cardano.KESAgent.KES.OCert (OCert (..)) @@ -159,9 +159,9 @@ decodeSig = do endOffset <- CBOR.peekByteOffset -- end of signed data - sigRawKESSignature <- SigKESSignature <$> CBOR.decodeBytes + sigRawKESSignature <- SigKESSignature <$> decodeSigKES sigRawOpCertificate <- decodeSigOpCertificate - sigRawColdKey <- SigColdKey <$> CBOR.decodeBytes + sigRawColdKey <- SigColdKey <$> decodeVerKeyDSIGN return $ \bytes -- ^ full bytes of the message, not just the sig part -> SigRawWithSignedBytes { sigRawSignedBytes = Utils.bytesBetweenOffsets startOffset endOffset bytes, @@ -176,13 +176,13 @@ decodeSig = do } } where - decodePayload :: CBOR.Decoder s (SigId, SigBody, SigKESPeriod, POSIXTime) + decodePayload :: CBOR.Decoder s (SigId, SigBody, KESPeriod, POSIXTime) decodePayload = do a <- CBOR.decodeListLen when (a /= 4) $ fail (printf "decodeSig: unexpected number of parameters %d for Sig's payload" a) (,,,) <$> decodeSigId <*> (SigBody <$> CBOR.decodeBytes) - <*> CBOR.decodeWord + <*> (KESPeriod <$> CBOR.decodeWord) <*> (realToFrac <$> CBOR.decodeWord32) diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs index e5d25651d87..4f42afaae50 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs @@ -4,8 +4,10 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module DMQ.Protocol.SigSubmission.Type @@ -14,7 +16,6 @@ module DMQ.Protocol.SigSubmission.Type , SigId (..) , SigBody (..) , SigKESSignature (..) - , SigKESPeriod , SigOpCertificate (..) , SigColdKey (..) , SigRaw (..) @@ -26,9 +27,12 @@ module DMQ.Protocol.SigSubmission.Type , POSIXTime -- * Utilities , CBORBytes (..) + -- * Re-exports from `kes-agent` + , KESPeriod (..) ) where import Data.Aeson +import Data.Bifunctor (first) import Data.ByteString (ByteString) import Data.ByteString.Base16 as BS.Base16 import Data.ByteString.Base16.Lazy as LBS.Base16 @@ -38,11 +42,13 @@ import Data.Text.Encoding qualified as Text import Data.Time.Clock.POSIX (POSIXTime) import Data.Typeable -import Cardano.Crypto.DSIGN.Class (DSIGNAlgorithm) -import Cardano.Crypto.KES.Class (VerKeyKES) --- import Cardano.Crypto.Util (SignableRepresentation (..)) +import Cardano.Crypto.DSIGN.Class (ContextDSIGN, DSIGNAlgorithm, VerKeyDSIGN) +import Cardano.Crypto.DSIGN.Class qualified as DSIGN +import Cardano.Crypto.KES.Class (KESAlgorithm (..), Signable) import Cardano.KESAgent.KES.Crypto as KES -import Cardano.KESAgent.KES.OCert (OCert (..)) +import Cardano.KESAgent.KES.Evolution qualified as KES +import Cardano.KESAgent.KES.OCert (KESPeriod (..), OCert (..), OCertSignable, + validateOCert) import Ouroboros.Network.Protocol.TxSubmission2.Type as SigSubmission hiding (TxSubmission2) @@ -66,13 +72,13 @@ newtype SigBody = SigBody { getSigBody :: ByteString } deriving stock (Show, Eq) --- TODO: --- This type should be something like: `SignedKES (KES crypto) SigPayload` -newtype SigKESSignature = SigKESSignature { getSigKESSignature :: ByteString } - deriving stock (Show, Eq) +newtype SigKESSignature crypto = SigKESSignature { getSigKESSignature :: SigKES (KES crypto) } + +deriving instance Show (SigKES (KES crypto)) + => Show (SigKESSignature crypto) +deriving instance Eq (SigKES (KES crypto)) + => Eq (SigKESSignature crypto) --- TODO: --- This type should be more than just a `ByteString`. newtype SigOpCertificate crypto = SigOpCertificate { getSigOpCertificate :: OCert crypto } deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) @@ -81,13 +87,16 @@ deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) => Show (SigOpCertificate crypto) deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) , Eq (VerKeyKES (KES crypto)) - ) => Eq (SigOpCertificate crypto) + ) => Eq (SigOpCertificate crypto) -type SigKESPeriod = Word +newtype SigColdKey crypto = SigColdKey { getSigColdKey :: VerKeyDSIGN (KES.DSIGN crypto) } -newtype SigColdKey = SigColdKey { getSigColdKey :: ByteString } - deriving stock (Show, Eq) +deriving instance Show (VerKeyDSIGN (KES.DSIGN crypto)) + => Show (SigColdKey crypto) + +deriving instance Eq (VerKeyDSIGN (KES.DSIGN crypto)) + => Eq (SigColdKey crypto) -- | Sig type consists of payload and its KES signature. -- @@ -95,23 +104,28 @@ newtype SigColdKey = SigColdKey { getSigColdKey :: ByteString } data SigRaw crypto = SigRaw { sigRawId :: SigId, sigRawBody :: SigBody, - sigRawKESPeriod :: SigKESPeriod, + sigRawKESPeriod :: KESPeriod, -- ^ KES period when this signature was created. -- -- NOTE: `kes-agent` library is using `Word` for KES period, CIP-137 -- requires `Word64`, thus we're only supporting 64-bit architectures. - sigRawExpiresAt :: POSIXTime, - sigRawKESSignature :: SigKESSignature, sigRawOpCertificate :: SigOpCertificate crypto, - sigRawColdKey :: SigColdKey + sigRawColdKey :: SigColdKey crypto, + sigRawExpiresAt :: POSIXTime, + sigRawKESSignature :: SigKESSignature crypto + -- ^ KES signature of all previous fields. + -- + -- NOTE: this field must be lazy, otetherwise tests will fail. } deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) , Show (VerKeyKES (KES crypto)) + , Show (SigKES (KES crypto)) ) => Show (SigRaw crypto) deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) , Eq (VerKeyKES (KES crypto)) + , Eq (SigKES (KES crypto)) ) => Eq (SigRaw crypto) @@ -151,10 +165,12 @@ data SigRawWithSignedBytes crypto = SigRawWithSignedBytes { deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) , Show (VerKeyKES (KES crypto)) + , Show (SigKES (KES crypto)) ) => Show (SigRawWithSignedBytes crypto) deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) , Eq (VerKeyKES (KES crypto)) + , Eq (SigKES (KES crypto)) ) => Eq (SigRawWithSignedBytes crypto) @@ -162,6 +178,7 @@ instance Crypto crypto => ToJSON (SigRawWithSignedBytes crypto) where toJSON SigRawWithSignedBytes {sigRaw} = toJSON sigRaw + data Sig crypto = SigWithBytes { sigRawBytes :: LBS.ByteString, -- ^ encoded `SigRaw` data type @@ -171,10 +188,12 @@ data Sig crypto = SigWithBytes { deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) , Show (VerKeyKES (KES crypto)) + , Show (SigKES (KES crypto)) ) => Show (Sig crypto) deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) , Eq (VerKeyKES (KES crypto)) + , Eq (SigKES (KES crypto)) ) => Eq (Sig crypto) @@ -187,10 +206,10 @@ instance Crypto crypto pattern Sig :: SigId -> SigBody - -> SigKESSignature - -> SigKESPeriod + -> SigKESSignature crypto + -> KESPeriod -> SigOpCertificate crypto - -> SigColdKey + -> SigColdKey crypto -> POSIXTime -> LBS.ByteString -> LBS.ByteString @@ -253,6 +272,7 @@ pattern instance Typeable crypto => ShowProxy (Sig crypto) where + type SigSubmission crypto = TxSubmission2.TxSubmission2 SigId (Sig crypto) diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs new file mode 100644 index 00000000000..a06bb3d6af4 --- /dev/null +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Encapsulates signature validation utilities leveraged by the mempool writer +-- +module DMQ.Protocol.SigSubmission.Validate where + +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Trans.Except +import Control.Monad.Trans.Except.Extra +import Data.Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust, isNothing) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Typeable +import Data.Word + +import Cardano.Crypto.DSIGN.Class (ContextDSIGN) +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.BaseTypes.NonZero +import Cardano.Ledger.Hashes + +import DMQ.Diffusion.NodeKernel (PoolValidationCtx (..)) +import DMQ.Protocol.SigSubmission.Type +import Ouroboros.Consensus.Shelley.Ledger.Query +import Ouroboros.Network.TxSubmission.Mempool.Simple +import Ouroboros.Network.Util.ShowProxy + + +-- | The type of non-fatal failures reported by the mempool writer +-- for invalid messages +-- +data instance MempoolAddFail (Sig crypto) = + SigInvalid SigValidationError + | SigDuplicate + | SigExpired + | SigResultOther Text + deriving (Eq, Show) + +instance (Typeable crypto) => ShowProxy (MempoolAddFail (Sig crypto)) + +instance ToJSON (MempoolAddFail (Sig crypto)) where + toJSON SigDuplicate = String "duplicate" + toJSON SigExpired = String "expired" + toJSON (SigInvalid txt) = object + [ "type" .= String "invalid" + -- , "reason" .= txt + ] + toJSON (SigResultOther txt) = object + [ "type" .= String "other" + , "reason" .= txt + ] + + +data SigValidationError = + InvalidKESSignature KESPeriod KESPeriod String + | InvalidSignatureOCERT + !Word64 -- OCert counter + !KESPeriod -- OCert KES period + !String -- DSIGN error message + | KESBeforeStartOCERT KESPeriod KESPeriod + | KESAfterEndOCERT KESPeriod KESPeriod + | UnrecognizedPool + | ExpiredPool + | NotInitialized + | ClockSkew + deriving (Eq, Show) + + +-- TODO: +-- We don't validate ocert numbers, since we might not have necessary +-- information to do so, but we can validate that they are growing. +validateSig :: forall crypto m. + ( Crypto crypto + , ContextDSIGN (KES.DSIGN crypto) ~ () + , DSIGN.Signable (DSIGN crypto) (OCertSignable crypto) + , ContextKES (KES crypto) ~ () + , Signable (KES crypto) ByteString + , Monad m + ) + => (DSIGN.VerKeyDSIGN (DSIGN crypto) -> KeyHash StakePool) + -> [Sig crypto] + -> PoolValidationCtx + -- ^ cardano pool id verification + -> ExceptT (Sig crypto, MempoolAddFail (Sig crypto)) m + [(Sig crypto, Either (MempoolAddFail (Sig crypto)) ())] +validateSig verKeyHashingFn sigs ctx = traverse process' sigs + where + DMQPoolValidationCtx now mNextEpoch pools = ctx + + process' sig = bimapExceptT (sig,) (sig,) $ process sig + + process Sig { sigSignedBytes = signedBytes, + sigKESPeriod, + sigOpCertificate = SigOpCertificate ocert@OCert { + ocertKESPeriod, + ocertVkHot, + ocertN + }, + sigColdKey = SigColdKey coldKey, + sigKESSignature = SigKESSignature kesSig + } = do + e1 <- sigKESPeriod < endKESPeriod + ?! KESAfterEndOCERT endKESPeriod sigKESPeriod + e2 <- sigKESPeriod >= startKESPeriod + ?! KESBeforeStartOCERT startKESPeriod sigKESPeriod + e3 <- case Map.lookup (verKeyHashingFn coldKey) pools of + Nothing | isNothing mNextEpoch + -> invalid SigResultOther $ Text.pack "not initialized yet" + | otherwise + -> left $ SigInvalid UnrecognizedPool + -- TODO make 5 a constant + Just ss | not (isZero (ssSetPool ss)) -> + if | now < nextEpoch -> success + -- localstatequery is late, but the pool is about to expire + | isZero (ssMarkPool ss) -> invalid SigInvalid ExpiredPool + -- we bound the time we're willing to approve a message + -- in case smth happened to localstatequery and it's taking + -- too long to update our state + | now <= addUTCTime 5 nextEpoch -> success + | otherwise -> invalid SigInvalid ClockSkew + | not (isZero (ssMarkPool ss)) -> + -- we take abs time in case we're late with our own + -- localstatequery update, and/or the other side's clock + -- is ahead, and we're just about or have just crossed the epoch + -- and the pool is expected to move into the set mark + if abs (diffUTCTime nextEpoch now) <= 5 + then success + else invalid SigInvalid ClockSkew + -- pool is deregistered and ineligible to mint blocks + | isZero (ssSetPool ss) -> + invalid SigInvalid ExpiredPool + | otherwise -> error "validateSig unexpected pool validation error" + where + -- mNextEpoch and pools are initialized in one STM transaction + -- and fromJust will not fail here + nextEpoch = fromJust mNextEpoch + + -- validate OCert, which includes verifying its signature + e4 <- validateOCert coldKey ocertVkHot ocert + ?!: InvalidSignatureOCERT ocertN sigKESPeriod + -- validate KES signature of the payload + e5 <- verifyKES () ocertVkHot + (unKESPeriod sigKESPeriod - unKESPeriod startKESPeriod) + (LBS.toStrict signedBytes) + kesSig + ?!: InvalidKESSignature ocertKESPeriod sigKESPeriod + -- for eg. remember to run all results with possibly non-fatal errors + right e3 + where + success = right $ Right () + invalid tag = right . Left . tag + + startKESPeriod, endKESPeriod :: KESPeriod + + startKESPeriod = ocertKESPeriod + -- TODO: is `totalPeriodsKES` the same as `praosMaxKESEvo` + -- or `sgMaxKESEvolution` in the genesis file? + endKESPeriod = KESPeriod $ unKESPeriod startKESPeriod + + totalPeriodsKES (Proxy :: Proxy (KES crypto)) + + (?!:) :: Either e1 () + -> (e1 -> SigValidationError) + -> ExceptT (MempoolAddFail (Sig crypto)) m + (Either (MempoolAddFail (Sig crypto)) ()) + (?!:) result f = firstExceptT (SigInvalid . f) . hoistEither . fmap Right $ result + + (?!) :: Bool + -> SigValidationError + -> ExceptT (MempoolAddFail (Sig crypto)) m + (Either (MempoolAddFail (Sig crypto)) ()) + (?!) flag sve = if flag then success else left (SigInvalid sve) + + infix 1 ?! + infix 1 ?!: diff --git a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs index bbccc6b1611..d4b6898c5e6 100644 --- a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs +++ b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -9,21 +11,28 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +#ifndef STANDARDCRYPTO_TESTS +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +#endif -module DMQ.Protocol.SigSubmission.Test where +module DMQ.Protocol.SigSubmission.Test (tests) where import Codec.CBOR.Encoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Write qualified as CBOR +import Control.Monad (zipWithM, (>=>)) import Control.Monad.ST (runST) import Data.Bifunctor (second) +import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as BL import Data.List.NonEmpty qualified as NonEmpty +import Data.Typeable import Data.Word (Word32) import GHC.TypeNats (KnownNat) import System.IO.Unsafe (unsafePerformIO) @@ -31,12 +40,15 @@ import System.IO.Unsafe (unsafePerformIO) import Network.TypedProtocol.Codec import Network.TypedProtocol.Codec.Properties hiding (prop_codec) +import Cardano.Crypto.DSIGN.Class (DSIGNAlgorithm, SignKeyDSIGN, + deriveVerKeyDSIGN, encodeVerKeyDSIGN) import Cardano.Crypto.DSIGN.Class qualified as DSIGN -import Cardano.Crypto.KES.Class (KESAlgorithm (..), VerKeyKES) +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.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) @@ -48,7 +60,7 @@ import DMQ.Protocol.SigSubmission.Type import Ouroboros.Network.Protocol.TxSubmission2.Test (labelMsg) import Test.Ouroboros.Network.Protocol.Utils (prop_codec_cborM, - prop_codec_valid_cbor_encoding, splits2, splits3) + prop_codec_valid_cbor_encoding, splits2) import Test.QuickCheck.Instances.ByteString () import Test.Tasty @@ -59,37 +71,55 @@ tests :: TestTree tests = testGroup "DMQ.Protocol" [ testGroup "SigSubmission" - [ testGroup "mockcrypto" - [ testProperty "OCert" prop_codec_ocert_mockcrypto - , testProperty "Sig" prop_codec_sig_mockcrypto - , testProperty "codec" prop_codec_mockcrypto - , testProperty "codec id" prop_codec_id_mockcrypto - , testProperty "codec 2-splits" $ withMaxSize 20 - $ withMaxSuccess 20 - prop_codec_splits2_mockcrypto - , testProperty "codec 3-splits" $ withMaxSize 10 - $ withMaxSuccess 10 - prop_codec_splits3_mockcrypto - , testProperty "codec cbor" prop_codec_cbor_mockcrypto - , testProperty "codec valid cbor" prop_codec_valid_cbor_mockcrypto + [ testGroup "Codec" + [ testGroup "MockCrypto" + [ testProperty "OCert" prop_codec_ocert_mockcrypto + , testProperty "Sig" prop_codec_sig_mockcrypto + , testProperty "codec" prop_codec_mockcrypto + , testProperty "codec id" prop_codec_id_mockcrypto + , testProperty "codec 2-splits" $ withMaxSize 20 + $ withMaxSuccess 20 + prop_codec_splits2_mockcrypto + -- MockCrypto produces too large messages for this test to run: + -- , testProperty "codec 3-splits" $ withMaxSize 10 + -- $ withMaxSuccess 10 + -- prop_codec_splits3_mockcrypto + , testProperty "codec cbor" prop_codec_cbor_mockcrypto + , testProperty "codec valid cbor" prop_codec_valid_cbor_mockcrypto + , testProperty "OCert" prop_codec_cbor_mockcrypto + ] +#ifdef STANDARDCRYPTO_TESTS + , testGroup "StandardCrypto" + [ testProperty "OCert" prop_codec_ocert_standardcrypto + , testProperty "Sig" prop_codec_sig_standardcrypto + , testProperty "codec" prop_codec_standardcrypto + , testProperty "codec id" prop_codec_id_standardcrypto + , testProperty "codec 2-splits" $ withMaxSize 20 + $ withMaxSuccess 20 + prop_codec_splits2_standardcrypto + -- StandardCrypto produces too large messages for this test to run: + {- + , testProperty "codec 3-splits" $ withMaxSize 10 + $ withMaxSuccess 10 + prop_codec_splits3_standardcrypto + -} + , testProperty "codec cbor" prop_codec_cbor_standardcrypto + , testProperty "codec valid cbor" prop_codec_valid_cbor_standardcrypto + ] +#endif + ] + ] + , testGroup "Crypto" + [ testGroup "MockCrypto" + [ testProperty "KES sign verify" prop_sign_verify_mockcrypto + , testProperty "validateSig" prop_validateSig_mockcrypto ] - , testGroup "standardcrypto" - [ testProperty "OCert" prop_codec_ocert_standardcrypto - , testProperty "Sig" prop_codec_sig_standardcrypto - , testProperty "codec" prop_codec_standardcrypto - , testProperty "codec id" prop_codec_id_standardcrypto - , testProperty "codec 2-splits" $ withMaxSize 20 - $ withMaxSuccess 20 - prop_codec_splits2_standardcrypto - -- StandardCrypt produces too large messages for this test to run: - {- - , testProperty "codec 3-splits" $ withMaxSize 10 - $ withMaxSuccess 10 - prop_codec_splits3_standardcrypto - -} - , testProperty "codec cbor" prop_codec_cbor_standardcrypto - , testProperty "codec valid cbor" prop_codec_valid_cbor_standardcrypto +#ifdef STANDARDCRYPTO_TESTS + , testGroup "StandardCrypto" + [ testProperty "KES sign verify" prop_sign_verify_standardcrypto + , testProperty "validateSig" prop_validateSig_standardcrypto ] +#endif ] ] @@ -111,31 +141,65 @@ instance Arbitrary POSIXTime where -- shrink via Word32 (e.g. in seconds) shrink posix = realToFrac <$> shrink (floor @_ @Word32 posix) -instance Arbitrary SigKESSignature where - arbitrary = SigKESSignature <$> arbitrary - shrink = map SigKESSignature . shrink . getSigKESSignature -mkVerKeyKES +-- | Make a KES key pair. +-- +mkKeysKES :: forall kesCrypto. KESAlgorithm kesCrypto => PinnedSizedBytes (SeedSizeKES kesCrypto) - -> IO (VerKeyKES kesCrypto) -mkVerKeyKES seed = do - withMLockedSeedFromPSB seed $ \mseed -> - KES.genKeyKES mseed >>= deriveVerKeyKES + -> IO (SignKeyKES kesCrypto, VerKeyKES kesCrypto) +mkKeysKES seed = + withMLockedSeedFromPSB seed $ \mseed -> do + snKESKey <- KES.genKeyKES mseed + (snKESKey,) <$> deriveVerKeyKES snKESKey +-- | The idea of this data type is to go around limitation of QuickCheck `Gen` +-- type, which does not allow IO actions. So instead we generate some random +-- context (e.g. key seed) and then the data is created when the property +-- runs. +-- +-- Keeping the `key` seprate allows to have access to it when shrinking, see +-- `shrinkWithConstr`, this is important when the signed data is shrinked and +-- we need to update a KES signature as well. +-- +-- However the limitation is shrinking: it requires `unsafePerformIO` anyway, +-- see `shrinkWithConstr`. +-- +-- TODO: to avoid complexity can we use `UnsoundPureKESAlgorithm` instead of +-- `KESAlgorithm`? +-- data WithConstr ctx key a = - WithConstr { constr :: key -> a, + WithConstr { constr :: key -> IO a, mkKey :: ctx -> IO key, ctx :: ctx } deriving instance Functor (WithConstr ctx key) +withConstrBind :: WithConstr ctx key a -> (a -> IO b) -> WithConstr ctx key b +withConstrBind WithConstr { constr, mkKey, ctx } fn = + WithConstr { constr = constr >=> fn, + mkKey, + ctx + } + +runWithConstr :: WithConstr ctx key a -> IO a +runWithConstr WithConstr { constr, mkKey, ctx } = mkKey ctx >>= constr + +constrWithKeys + :: (keys -> IO a) + -> WithConstr ctx keys keys + -> WithConstr ctx keys a +constrWithKeys f WithConstr { constr, mkKey, ctx } = + WithConstr { constr = constr >=> f, + mkKey, + ctx + } constWithConstr :: a -> WithConstr [ctx] [key] a constWithConstr a = - WithConstr { constr = const a, + WithConstr { constr = const (pure a), mkKey = \_ -> pure [], ctx = [] } @@ -146,16 +210,16 @@ listWithConstr :: forall ctx key a b. -> WithConstr [ctx] [key] b listWithConstr constr' as = WithConstr { - constr = \keys -> constr' (zipWith ($) constrs keys), - mkKey = \ctxs -> sequence (zipWith ($) mkKeys ctxs), + constr = \keys -> constr' <$> zipWithM ($) constrs keys, + mkKey = \ctxs -> zipWithM ($) mkKeys ctxs, ctx = ctx <$> as } where - constrs :: [(key -> a)] + constrs :: [key -> IO a] constrs = constr <$> as - mkKeys :: [(ctx -> IO key)] + mkKeys :: [ctx -> IO key] mkKeys = mkKey <$> as @@ -168,7 +232,7 @@ shrinkWithConstrCtx constr@WithConstr { ctx } = sequenceWithConstr - :: (a -> key -> a) + :: (a -> key -> IO a) -> WithConstr ctx key [a] -> IO [WithConstr ctx key a] sequenceWithConstr update constr@WithConstr { mkKey, ctx } = do @@ -180,33 +244,30 @@ sequenceWithConstr update constr@WithConstr { mkKey, ctx } = do -- unsafePerformIO :( shrinkWithConstr :: Arbitrary ctx - => (a -> key -> a) + => (a -> key -> IO a) -> (a -> [a]) - -> WithConstr ctx key a + -> WithConstr ctx key a -> [WithConstr ctx key a] shrinkWithConstr update shrinker constr = unsafePerformIO (sequenceWithConstr update $ shrinker <$> constr) ++ shrinkWithConstrCtx constr -runWithConstr :: WithConstr ctx key a -> IO a -runWithConstr WithConstr { constr, mkKey, ctx } = constr <$> mkKey ctx - +type KESCTX size = PinnedSizedBytes size +type WithConstrKES size crypto a = WithConstr (KESCTX size) (SignKeyKES crypto, VerKeyKES crypto) a +type WithConstrKESList size crypto a = WithConstr [KESCTX size] [(SignKeyKES crypto, VerKeyKES crypto)] a -type VerKeyKESCTX size = PinnedSizedBytes size -type WithConstrVerKeyKES size crypto a = WithConstr (VerKeyKESCTX size) (VerKeyKES crypto) a -type WithConstrVerKeyKESList size crypto a = WithConstr [VerKeyKESCTX size] [VerKeyKES crypto] a -mkVerKeyKESConstr +mkKeysKESConstr :: forall kesCrypto. KESAlgorithm kesCrypto - => VerKeyKESCTX (SeedSizeKES kesCrypto) - -> WithConstrVerKeyKES (SeedSizeKES kesCrypto) - kesCrypto - (VerKeyKES kesCrypto) -mkVerKeyKESConstr ctx = - WithConstr { constr = id, - mkKey = mkVerKeyKES, + => KESCTX (SeedSizeKES kesCrypto) + -> WithConstrKES (SeedSizeKES kesCrypto) + kesCrypto + (SignKeyKES kesCrypto, VerKeyKES kesCrypto) +mkKeysKESConstr ctx = + WithConstr { constr = pure, + mkKey = mkKeysKES, ctx } @@ -214,71 +275,115 @@ instance ( size ~ SeedSizeKES kesCrypto , KnownNat size , KESAlgorithm kesCrypto ) - => Arbitrary (WithConstrVerKeyKES size kesCrypto (VerKeyKES kesCrypto)) where - arbitrary = mkVerKeyKESConstr <$> arbitrary + => Arbitrary (WithConstrKES size kesCrypto (SignKeyKES kesCrypto, VerKeyKES kesCrypto)) where + arbitrary = mkKeysKESConstr <$> arbitrary shrink = shrinkWithConstrCtx +-- | An auxiliary data type to hold KES keys along with an OCert, payload and +-- its KES signature. +data CryptoCtx crypto = CryptoCtx { + snKESKey :: SignKeyKES (KES crypto), + -- ^ signing KES key + vnKESKey :: VerKeyKES (KES crypto), + -- ^ verification KES key + coldKey :: SignKeyDSIGN (DSIGN crypto), + -- ^ signing cold key + ocert :: OCert crypto + -- ^ ocert + } + + instance ( Crypto crypto , DSIGN.Signable (DSIGN crypto) (KES.OCertSignable crypto) , DSIGN.ContextDSIGN (DSIGN crypto) ~ () + , ContextKES (KES crypto) ~ () , kesCrypto ~ KES crypto + , KESAlgorithm kesCrypto + , Signable kesCrypto ByteString , size ~ SeedSizeKES kesCrypto , KnownNat size ) - => Arbitrary (WithConstrVerKeyKES size kesCrypto (OCert crypto)) where + => Arbitrary (WithConstrKES size kesCrypto (CryptoCtx crypto)) where arbitrary = do - verKeyKES <- arbitrary + withKeys <- arbitrary n <- arbitrary seedColdKey :: PinnedSizedBytes (DSIGN.SeedSizeDSIGN (DSIGN crypto)) <- arbitrary - let !skCold = DSIGN.genKeyDSIGN (mkSeedFromBytes . psbToByteString $ seedColdKey) + let !coldKey = DSIGN.genKeyDSIGN (mkSeedFromBytes . psbToByteString $ seedColdKey) period <- KES.KESPeriod <$> arbitrary - return $ fmap (\vkKES -> KES.makeOCert vkKES n period skCold) verKeyKES - shrink = shrinkWithConstrCtx - - -instance ( kesCrypto ~ KES crypto - , size ~ SeedSizeKES kesCrypto - , KnownNat size - , Arbitrary (WithConstrVerKeyKES size kesCrypto (OCert crypto)) - ) - => Arbitrary (WithConstrVerKeyKES size kesCrypto (SigOpCertificate crypto)) where - arbitrary = fmap SigOpCertificate <$> arbitrary + return $ constrWithKeys + (\(snKESKey, vnKESKey) -> + return $ CryptoCtx { + snKESKey, + vnKESKey, + coldKey, + ocert = KES.makeOCert vnKESKey n period coldKey + }) + withKeys shrink = shrinkWithConstrCtx instance ( Crypto crypto , kesCrypto ~ KES crypto + , ContextKES kesCrypto ~ () , size ~ SeedSizeKES kesCrypto - , Arbitrary (WithConstrVerKeyKES size kesCrypto (OCert crypto)) + , Signable kesCrypto ByteString + , dsignCrypto ~ DSIGN crypto + , DSIGNAlgorithm dsignCrypto + , Arbitrary (WithConstrKES size kesCrypto (CryptoCtx crypto)) ) - => Arbitrary (WithConstrVerKeyKES size kesCrypto (SigRawWithSignedBytes crypto)) where + => Arbitrary (WithConstrKES size kesCrypto (SigRawWithSignedBytes crypto)) where arbitrary = do sigRawId <- arbitrary - sigRawBody <- arbitrary sigRawExpiresAt <- arbitrary - opCert <- arbitrary - sigRawKESPeriod <- arbitrary - sigRawKESSignature <- arbitrary - sigRawColdKey <- arbitrary - return $ fmap (\cert -> let sigRawOpCertificate = SigOpCertificate cert - sigRaw = SigRaw { - sigRawId, - sigRawBody, - sigRawKESPeriod, - sigRawOpCertificate, - sigRawColdKey, - sigRawExpiresAt, - sigRawKESSignature = undefined -- to be filled below - } - signedBytes = CBOR.toStrictByteString (encodeSigRaw' sigRaw) - in - SigRawWithSignedBytes { - sigRawSignedBytes = BL.fromStrict signedBytes, - sigRaw = sigRaw { sigRawKESSignature } - } - ) opCert + let maxKESOffset :: Word + maxKESOffset = totalPeriodsKES (Proxy :: Proxy kesCrypto) + -- offset since `ocertKESPeriod`, so that the signature is still valid + kesOffset <- arbitrary `suchThat` (< maxKESOffset) + payload <- arbitrary + crypto <- arbitrary + return $ withConstrBind crypto \CryptoCtx {ocert, coldKey, snKESKey} -> do + let sigRawOpCertificate :: SigOpCertificate crypto + sigRawOpCertificate = SigOpCertificate ocert + + sigRawBody :: SigBody + sigRawBody = SigBody payload + + sigRawColdKey :: SigColdKey crypto + sigRawColdKey = SigColdKey $ deriveVerKeyDSIGN coldKey + + sigRawKESPeriod :: KESPeriod + sigRawKESPeriod = KESPeriod $ unKESPeriod (ocertKESPeriod ocert) + + kesOffset + + sigRaw = SigRaw { + sigRawId, + sigRawBody, + sigRawKESPeriod, + sigRawOpCertificate, + sigRawColdKey, + sigRawExpiresAt, + sigRawKESSignature = undefined -- to be filled below + } + signedBytes = CBOR.toStrictByteString (encodeSigRaw' sigRaw) + + -- evolve the key to the target period + mbSnKESKey <- KES.updateKESTo () sigRawKESPeriod ocert (KES.SignKeyWithPeriodKES snKESKey 0) + case mbSnKESKey of + Just (KES.SignKeyWithPeriodKES snKESKey' _) -> do + -- signed bytes with the snKESKey' + sigRawKESSignature + <- SigKESSignature + <$> KES.signKES () kesOffset signedBytes snKESKey' + return SigRawWithSignedBytes { + sigRawSignedBytes = BL.fromStrict signedBytes, + sigRaw = sigRaw { sigRawKESSignature } + } + Nothing -> + error $ "arbitrary SigRawWithSignedBytes: could not evolve KES key to the target period by KES offset: " + ++ show kesOffset + shrink = shrinkWithConstrSigRawWithSignedBytes @@ -289,26 +394,38 @@ instance ( Crypto crypto -- shrinkWithConstrSigRawWithSignedBytes :: forall crypto. - Crypto crypto - => WithConstrVerKeyKES (SeedSizeKES (KES crypto)) (KES crypto) (SigRawWithSignedBytes crypto) - -> [WithConstrVerKeyKES (SeedSizeKES (KES crypto)) (KES crypto) (SigRawWithSignedBytes crypto)] + ( Crypto crypto + , ContextKES (KES crypto) ~ () + , Signable (KES crypto) ByteString + ) + => WithConstrKES (SeedSizeKES (KES crypto)) (KES crypto) (SigRawWithSignedBytes crypto) + -> [WithConstrKES (SeedSizeKES (KES crypto)) (KES crypto) (SigRawWithSignedBytes crypto)] shrinkWithConstrSigRawWithSignedBytes = shrinkWithConstr updateFn shrinkSigRawWithSignedBytesFn where updateFn :: SigRawWithSignedBytes crypto - -> VerKeyKES (KES crypto) - -> SigRawWithSignedBytes crypto + -> (SignKeyKES (KES crypto), VerKeyKES (KES crypto)) + -> IO (SigRawWithSignedBytes crypto) updateFn SigRawWithSignedBytes { - sigRaw = sigRaw@SigRaw { sigRawOpCertificate = SigOpCertificate ocert }, + sigRaw = sigRaw@SigRaw { sigRawOpCertificate = SigOpCertificate ocert, + sigRawKESPeriod + }, sigRawSignedBytes } - ocertVkHot - = + (snKeyKES, ocertVkHot) + = do let sigRaw' = sigRaw { sigRawOpCertificate = SigOpCertificate ocert { ocertVkHot } } - in SigRawWithSignedBytes { - sigRaw = sigRaw', + -- update KES key to sigRawKESPeriod + Just (KES.SignKeyWithPeriodKES snKeyKES' _) + <- KES.updateKESTo () sigRawKESPeriod ocert (KES.SignKeyWithPeriodKES snKeyKES 0) + -- sign the message + sign <- KES.signKES () (KES.unKESPeriod sigRawKESPeriod - KES.unKESPeriod (ocertKESPeriod ocert)) + (BL.toStrict sigRawSignedBytes) + snKeyKES' + pure $ SigRawWithSignedBytes { + sigRaw = sigRaw' { sigRawKESSignature = SigKESSignature sign }, sigRawSignedBytes } @@ -326,11 +443,18 @@ shrinkSigRawWithSignedBytesFn SigRawWithSignedBytes { sigRaw } = | sigRaw' <- shrinkSigRawFn sigRaw , let sigRawSignedBytes' = CBOR.toLazyByteString (encodeSigRaw' sigRaw') ] + + +-- | Pure shrinking function for `SigRaw`. It does not update the KES +-- signature. +-- shrinkSigRawFn :: SigRaw crypto -> [SigRaw crypto] shrinkSigRawFn sig@SigRaw { sigRawId, - sigRawBody, - sigRawExpiresAt - } = + sigRawBody, + sigRawKESPeriod, + sigRawExpiresAt, + sigRawOpCertificate = SigOpCertificate ocert + } = [ sig { sigRawId = sigRawId' } | sigRawId' <- shrink sigRawId ] @@ -339,23 +463,15 @@ shrinkSigRawFn sig@SigRaw { sigRawId, | sigRawBody' <- shrink sigRawBody ] ++ + [ sig { sigRawKESPeriod = sigRawKESPeriod' } + | sigRawKESPeriod' <- KESPeriod <$> shrink (unKESPeriod sigRawKESPeriod) + , sigRawKESPeriod' >= ocertKESPeriod ocert + ] + ++ [ sig { sigRawExpiresAt = sigRawExpiresAt' } | sigRawExpiresAt' <- shrink sigRawExpiresAt ] -instance Arbitrary SigColdKey where - arbitrary = SigColdKey <$> arbitrary - shrink = map SigColdKey . shrink . getSigColdKey - - -mkSigRawWithSignedBytes :: SigRaw crypto -> SigRawWithSignedBytes crypto -mkSigRawWithSignedBytes sigRaw = - SigRawWithSignedBytes { - sigRaw, - sigRawSignedBytes - } - where - sigRawSignedBytes = CBOR.toLazyByteString (encodeSigRaw' sigRaw) -- NOTE: this function is not exposed in the main library on purpose. We -- should never construct `Sig` by serialising `SigRaw`. @@ -368,7 +484,7 @@ mkSig sigRawWithSignedBytes@SigRawWithSignedBytes { sigRaw } = sigRawWithSignedBytes } where - sigRawBytes = CBOR.toLazyByteString (encodeSigRaw sigRaw) + sigRawBytes = CBOR.toLazyByteString (encodeSigRaw sigRaw) -- encode only signed part @@ -383,7 +499,7 @@ encodeSigRaw' SigRaw { = CBOR.encodeListLen 4 <> encodeSigId sigRawId <> CBOR.encodeBytes (getSigBody sigRawBody) - <> CBOR.encodeWord sigRawKESPeriod + <> CBOR.encodeWord (unKESPeriod sigRawKESPeriod) <> CBOR.encodeWord32 (floor sigRawExpiresAt) -- encode together with KES signature, OCert and cold key. @@ -393,41 +509,60 @@ encodeSigRaw :: Crypto crypto encodeSigRaw sigRaw@SigRaw { sigRawKESSignature, sigRawOpCertificate, sigRawColdKey } = CBOR.encodeListLen 4 <> encodeSigRaw' sigRaw - <> CBOR.encodeBytes (getSigKESSignature sigRawKESSignature) + <> encodeSigKES (getSigKESSignature sigRawKESSignature) <> encodeSigOpCertificate sigRawOpCertificate - <> CBOR.encodeBytes (getSigColdKey sigRawColdKey) - + <> encodeVerKeyDSIGN (getSigColdKey sigRawColdKey) -shrinkSigFn :: forall crypto. Crypto crypto +-- note: KES signature is updated by updateSigFn +shrinkSigFn :: forall crypto. + Crypto crypto => Sig crypto -> [Sig crypto] shrinkSigFn SigWithBytes {sigRawWithSignedBytes = SigRawWithSignedBytes { sigRaw, sigRawSignedBytes } } = mkSig . (\sigRaw' -> SigRawWithSignedBytes { sigRaw = sigRaw', sigRawSignedBytes }) <$> shrinkSigRawFn sigRaw + +updateSigFn :: forall crypto. + KESAlgorithm (KES crypto) + => ContextKES (KES crypto) ~ () + => Signable (KES crypto) ByteString + => Sig crypto + -> (SignKeyKES (KES crypto), VerKeyKES (KES crypto)) + -> IO (Sig crypto) +updateSigFn + sig@Sig { sigOpCertificate = SigOpCertificate opCert, + sigBody = SigBody body + } + (snKESKey, vnKESKey) + = do + signature <- KES.signKES () (KES.unKESPeriod (ocertKESPeriod opCert)) body snKESKey + return $ sig { sigOpCertificate = SigOpCertificate opCert { ocertVkHot = vnKESKey}, + sigKESSignature = SigKESSignature signature + } + + instance ( Crypto crypto , DSIGN.ContextDSIGN (DSIGN crypto) ~ () , DSIGN.Signable (DSIGN crypto) (KES.OCertSignable crypto) , kesCrypto ~ KES crypto + , ContextKES kesCrypto ~ () + , Signable kesCrypto ByteString , size ~ SeedSizeKES kesCrypto , KnownNat size ) - => Arbitrary (WithConstrVerKeyKES size kesCrypto (Sig crypto)) where + => Arbitrary (WithConstrKES size kesCrypto (Sig crypto)) where arbitrary = fmap mkSig <$> arbitrary shrink = shrinkWithConstr updateSigFn shrinkSigFn -updateSigFn :: Sig crypto -> VerKeyKES (KES crypto) -> Sig crypto -updateSigFn - sig@Sig {sigOpCertificate = SigOpCertificate opCert} - ocertVkHot - = - sig { sigOpCertificate = SigOpCertificate opCert { ocertVkHot } } - instance ( kesCrypto ~ KES crypto + , KESAlgorithm kesCrypto + , ContextKES kesCrypto ~ () + , Signable kesCrypto ByteString , size ~ SeedSizeKES kesCrypto , KnownNat size - , Arbitrary (WithConstrVerKeyKES size kesCrypto (Sig crypto)) + , Arbitrary (WithConstrKES size kesCrypto (Sig crypto)) ) - => Arbitrary (WithConstrVerKeyKESList size kesCrypto (AnyMessage (SigSubmission crypto))) where + => Arbitrary (WithConstrKESList size kesCrypto (AnyMessage (SigSubmission crypto))) where arbitrary = oneof [ pure . constWithConstr $ AnyMessage MsgInit , constWithConstr . AnyMessage <$> @@ -451,15 +586,19 @@ instance ( kesCrypto ~ KES crypto , constWithConstr . AnyMessage <$> MsgRequestTxs <$> arbitrary , listWithConstr (AnyMessage . MsgReplyTxs) - <$> (arbitrary :: Gen [WithConstrVerKeyKES size kesCrypto (Sig crypto)]) + <$> (arbitrary :: Gen [WithConstrKES size kesCrypto (Sig crypto)]) , constWithConstr . AnyMessage <$> pure MsgDone ] shrink = shrinkWithConstr updateFn shrinkFn where - updateFn :: AnyMessage (SigSubmission crypto) -> [VerKeyKES kesCrypto] -> AnyMessage (SigSubmission crypto) - updateFn (AnyMessage (MsgReplyTxs txs)) vkKeyKESs = AnyMessage (MsgReplyTxs (zipWith updateSigFn txs vkKeyKESs)) - updateFn msg _ = msg + updateFn :: AnyMessage (SigSubmission crypto) + -> [(SignKeyKES kesCrypto, VerKeyKES kesCrypto)] + -> IO (AnyMessage (SigSubmission crypto)) + updateFn (AnyMessage (MsgReplyTxs txs)) keys = do + sigs <- traverse (uncurry updateSigFn) (zip txs keys) + return $ AnyMessage (MsgReplyTxs sigs) + updateFn msg _ = pure msg shrinkFn :: AnyMessage (SigSubmission crypto) -> [AnyMessage (SigSubmission crypto)] shrinkFn = \case @@ -494,10 +633,10 @@ instance ( kesCrypto ~ KES crypto prop_codec_ocert :: forall crypto. Crypto crypto - => WithConstrVerKeyKES (SeedSizeKES (KES crypto)) (KES crypto) (OCert crypto) + => WithConstrKES (SeedSizeKES (KES crypto)) (KES crypto) (CryptoCtx crypto) -> Property prop_codec_ocert constr = ioProperty $ do - ocert <- runWithConstr constr + CryptoCtx { ocert } <- runWithConstr constr return . counterexample (show ocert) $ let encoded = CBOR.toLazyByteString (encodeSigOpCertificate (SigOpCertificate ocert)) in case CBOR.deserialiseFromBytes decodeSigOpCertificate encoded of @@ -507,12 +646,12 @@ prop_codec_ocert constr = ioProperty $ do .&&. BL.null bytes prop_codec_ocert_mockcrypto - :: Blind (WithConstrVerKeyKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (OCert MockCrypto)) + :: Blind (WithConstrKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (CryptoCtx MockCrypto)) -> Property prop_codec_ocert_mockcrypto = prop_codec_ocert . getBlind prop_codec_ocert_standardcrypto - :: Blind (WithConstrVerKeyKES (SeedSizeKES (KES StandardCrypto)) (KES StandardCrypto) (OCert StandardCrypto)) + :: Blind (WithConstrKES (SeedSizeKES (KES StandardCrypto)) (KES StandardCrypto) (CryptoCtx StandardCrypto)) -> Property prop_codec_ocert_standardcrypto = prop_codec_ocert . getBlind @@ -523,7 +662,7 @@ prop_codec_ocert_standardcrypto = prop_codec_ocert . getBlind -- * signed bytes match the encoding of `encodeSigRaw'`. prop_codec_sig :: forall crypto. Crypto crypto - => WithConstrVerKeyKES (SeedSizeKES (KES crypto)) (KES crypto) (Sig crypto) + => WithConstrKES (SeedSizeKES (KES crypto)) (KES crypto) (Sig crypto) -> Property prop_codec_sig constr = ioProperty $ do sig <- runWithConstr constr @@ -556,17 +695,17 @@ prop_codec_sig constr = ioProperty $ do .&&. BL.null leftovers prop_codec_sig_mockcrypto - :: Blind (WithConstrVerKeyKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (Sig MockCrypto)) + :: Blind (WithConstrKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (Sig MockCrypto)) -> Property prop_codec_sig_mockcrypto = prop_codec_sig . getBlind prop_codec_sig_standardcrypto - :: Blind (WithConstrVerKeyKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (Sig MockCrypto)) + :: Blind (WithConstrKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (Sig MockCrypto)) -> Property prop_codec_sig_standardcrypto = prop_codec_sig . getBlind -type AnySigMessage crypto = WithConstrVerKeyKESList (SeedSizeKES (KES crypto)) (KES crypto) (AnyMessage (SigSubmission crypto)) +type AnySigMessage crypto = WithConstrKESList (SeedSizeKES (KES crypto)) (KES crypto) (AnyMessage (SigSubmission crypto)) prop_codec :: forall crypto. Crypto crypto @@ -619,6 +758,9 @@ prop_codec_splits2_standardcrypto :: Blind (AnySigMessage StandardCrypto) -> Pro prop_codec_splits2_standardcrypto = prop_codec_splits2 . getBlind +{- +-- TODO: we need a different splits3 function that does not explore all the +-- ways of splitting a message into three chunks. prop_codec_splits3 :: forall crypto. Crypto crypto => AnySigMessage crypto -> Property prop_codec_splits3 constr = ioProperty $ do @@ -629,9 +771,12 @@ prop_codec_splits3 constr = ioProperty $ do prop_codec_splits3_mockcrypto :: Blind (AnySigMessage MockCrypto) -> Property prop_codec_splits3_mockcrypto = prop_codec_splits3 . getBlind +-} +{- prop_codec_splits3_standardcrypto :: Blind (AnySigMessage StandardCrypto) -> Property prop_codec_splits3_standardcrypto = prop_codec_splits3 . getBlind +-} prop_codec_cbor @@ -672,3 +817,74 @@ prop_codec_valid_cbor_standardcrypto :: Blind (AnySigMessage StandardCrypto) -> Property prop_codec_valid_cbor_standardcrypto = prop_codec_valid_cbor . getBlind + + +-- | Check that the KES signature is valid. +-- +prop_validateSig + :: ( Crypto crypto + , DSIGN.ContextDSIGN (DSIGN crypto) ~ () + , DSIGN.Signable (DSIGN crypto) (KES.OCertSignable crypto) + , KES.ContextKES (KES crypto) ~ () + , KES.Signable (KES crypto) ByteString + ) + => WithConstrKES size kesCrypt (Sig crypto) + -> Property +prop_validateSig constr = ioProperty $ do + sig <- runWithConstr constr + return $ case validateSig KES.defEvolutionConfig sig of + Left err -> counterexample ("KES seed: " ++ show (ctx constr)) + . counterexample ("KES vk key: " ++ show (ocertVkHot . getSigOpCertificate . sigOpCertificate $ sig)) + . counterexample (show sig) + . counterexample (show err) + $ False + Right () -> property True + +prop_validateSig_mockcrypto + :: Blind (WithConstrKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (Sig MockCrypto)) + -> Property +prop_validateSig_mockcrypto = prop_validateSig . getBlind + +-- TODO: FAILS, why? +prop_validateSig_standardcrypto + :: Blind (WithConstrKES (SeedSizeKES (KES StandardCrypto)) (KES StandardCrypto) (Sig StandardCrypto)) + -> Property +prop_validateSig_standardcrypto = prop_validateSig . getBlind + + +-- | Sign & verify a payload with KES keys. +-- +prop_sign_verify + :: ( Crypto crypto + , ContextKES (KES crypto) ~ () + , Signable (KES crypto) ByteString + ) + => WithConstrKES (SeedSizeKES (KES crypto)) (KES crypto) (CryptoCtx crypto) + -- ^ KES keys + -> ByteString + -- ^ payload + -> Property +prop_sign_verify constr payload = ioProperty $ do + CryptoCtx { snKESKey, vnKESKey } <- runWithConstr constr + signed <- KES.signKES () 0 payload snKESKey + let res = KES.verifyKES () vnKESKey 0 payload signed + return $ counterexample "KES signature does not verify" + $ case res of + Left err -> counterexample (show err) + . counterexample ("vnKESKey: " ++ show vnKESKey) + . counterexample ("signature: " ++ show signed) + $ False + Right () -> property True + + +prop_sign_verify_mockcrypto + :: Blind (WithConstrKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (CryptoCtx MockCrypto)) + -> ByteString + -> Property +prop_sign_verify_mockcrypto = prop_sign_verify . getBlind + +prop_sign_verify_standardcrypto + :: Blind (WithConstrKES (SeedSizeKES (KES StandardCrypto)) (KES StandardCrypto) (CryptoCtx StandardCrypto)) + -> ByteString + -> Property +prop_sign_verify_standardcrypto = prop_sign_verify . getBlind diff --git a/nix/ouroboros-network.nix b/nix/ouroboros-network.nix index c819a4d09d0..20d5662d744 100644 --- a/nix/ouroboros-network.nix +++ b/nix/ouroboros-network.nix @@ -43,10 +43,12 @@ let # stdenv.hostPlatform.isWindows will work as expected src = ./..; name = "ouroboros-network"; + index-state = "2025-07-16T09:24:19Z"; + index-sha256 = "sha256-fmnSRF68/UIQYzzdmNs3UT0cbYhn9d5nlhb3BnVXe48="; compiler-nix-name = lib.mkDefault defaultCompiler; cabalProjectLocal = if pkgs.stdenv.hostPlatform.isWindows - then lib.readFile ../scripts/ci/cabal.project.local.Windows + then lib.readFile ../scripts/ci/cabal.project.local.Nix.Windows else lib.readFile ../scripts/ci/cabal.project.local.Linux; # diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index e46798f9359..8c4c1369bdb 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -9,10 +9,10 @@ * `Ouroboros.Network.NodeTo{Client,Node}` modules moved to `ouroboros-network:cardano-diffusion` (as `Cardano.Network.NodeTo{Node,Client}`) -* Adapt to simplified type of `headerForgeUTCTime` in `BlockFetchConsensusInterface`. +* (REVERTED temporarily) Adapt to simplified type of `headerForgeUTCTime` in `BlockFetchConsensusInterface`. * Type of `defaultSyncTargets` changed. * Type of `defaultPeerSharing` changed. -* Adapted to changes of `BlockFetchConsensusInterface`. +* (REVERTED temporarily) Adapted to changes of `BlockFetchConsensusInterface`. * `Ouroboros.Network.TxSubmission.Inbound` moved to `Ouroboros.Network.TxSubmission.Inbound.V1` * `Ouroboros.Network.TxSubmission.Inbound.V1.txSubmissionInbound` takes extra argument: `TxSubmissionInitDelay` (previously configurable through `cabal` flags). * Removed the `txsubmission-delay` cabal flag. diff --git a/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index 5b84eff0366..08f9dd8aafd 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -1,20 +1,14 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} module Ouroboros.Network.BlockFetch.ConsensusInterface ( PraosFetchMode (..) , FetchMode (..) , BlockFetchConsensusInterface (..) + , FromConsensus (..) , ChainSelStarvation (..) - , ChainComparison (..) - -- * Utilities - , WithFingerprint (..) - , Fingerprint (..) - , initialWithFingerprint ) where import Control.Monad.Class.MonadSTM @@ -22,7 +16,6 @@ import Control.Monad.Class.MonadTime (UTCTime) import Control.Monad.Class.MonadTime.SI (Time) import Data.Map.Strict (Map) -import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks) @@ -115,9 +108,24 @@ data BlockFetchConsensusInterface peer header block m = -- have been downloaded anyway. readFetchedMaxSlotNo :: STM m MaxSlotNo, - -- | Compare chain fragments. This might involve further state, such as - -- Peras certificates (which give certain blocks additional weight). - readChainComparison :: STM m (WithFingerprint (ChainComparison header)), + -- | Given the current chain, is the given chain plausible as a + -- candidate chain. Classically for Ouroboros this would simply + -- check if the candidate is strictly longer, but for Ouroboros + -- with operational key certificates there are also cases where + -- we would consider a chain of equal length to the current chain. + -- + plausibleCandidateChain :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header -> Bool, + + -- | Compare two candidate chains and return a preference ordering. + -- This is used as part of selecting which chains to prioritise for + -- downloading block bodies. + -- + compareCandidateChains :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header + -> Ordering, -- | Much of the logic for deciding which blocks to download from which -- peer depends on making estimates based on recent performance metrics. @@ -132,7 +140,19 @@ data BlockFetchConsensusInterface peer header block m = blockMatchesHeader :: header -> block -> Bool, -- | Calculate when a header's block was forged. - headerForgeUTCTime :: header -> UTCTime, + -- + -- PRECONDITION: This function will succeed and give a _correct_ result + -- when applied to headers obtained via this interface (ie via + -- Consensus, ie via 'readCurrentChain' or 'readCandidateChains'). + -- + -- WARNING: This function may fail or, worse, __give an incorrect result + -- (!!)__ if applied to headers obtained from sources outside of this + -- interface. The 'FromConsensus' newtype wrapper is intended to make it + -- difficult to make that mistake, so please pay that syntactic price + -- and consider its meaning at each call to this function. Relatedly, + -- preserve that argument wrapper as much as possible when deriving + -- ancillary functions\/interfaces from this function. + headerForgeUTCTime :: FromConsensus header -> STM m UTCTime, -- | Information on the ChainSel starvation status; whether it is ongoing -- or has ended recently. Needed by the bulk sync decision logic. @@ -156,58 +176,21 @@ data ChainSelStarvation | ChainSelStarvationEndedAt Time deriving (Eq, Show, NoThunks, Generic) - -data ChainComparison header = - ChainComparison { - -- | Given the current chain, is the given chain plausible as a candidate - -- chain. Classically for Ouroboros this would simply check if the - -- candidate is strictly longer, but it can also involve further - -- criteria: - -- - -- * Tiebreakers (e.g. based on the opcert numbers and VRFs) for chains - -- of equal length. - -- - -- * Weight in the context of Ouroboros Peras, due to a boost from a - -- Peras certificate. - -- - plausibleCandidateChain :: HasCallStack - => AnchoredFragment header - -> AnchoredFragment header - -> Bool, - - -- | Compare two candidate chains and return a preference ordering. - -- This is used as part of selecting which chains to prioritise for - -- downloading block bodies. - -- - -- PRECONDITION: The two fragments must intersect. - -- - compareCandidateChains :: HasCallStack - => AnchoredFragment header - -> AnchoredFragment header - -> Ordering - } - {------------------------------------------------------------------------------- - Utilities + Syntactic indicator of key precondition about Consensus time conversions -------------------------------------------------------------------------------} --- | Simple type that can be used to indicate some value (without/only with an --- expensive 'Eq' instance) changed. -newtype Fingerprint = Fingerprint Word64 - deriving stock (Show, Eq, Generic) - deriving newtype (Enum) - deriving anyclass (NoThunks) - --- | Store a value together with its 'Fingerprint'. -data WithFingerprint a = WithFingerprint - { forgetFingerprint :: !a - , getFingerprint :: !Fingerprint - } - deriving stock (Show, Functor, Generic) - deriving anyclass (NoThunks) - --- | Attach @'Fingerprint' 0@ to the given value. When the underlying @a@ is --- changed, the 'Fingerprint' must be updated to a new unique value (e.g. via --- 'succ'). -initialWithFingerprint :: a -> WithFingerprint a -initialWithFingerprint a = WithFingerprint a (Fingerprint 0) +-- | A new type used to emphasize the precondition of +-- 'Ouroboros.Network.BlockFetch.ConsensusInterface.headerForgeUTCTime' at each +-- call site. +-- +-- At time of writing, the @a@ is either a header or a block. The headers are +-- literally from Consensus (ie provided by ChainSync). Blocks, on the other +-- hand, are indirectly from Consensus: they were fetched only because we +-- favored the corresponding header that Consensus provided. +newtype FromConsensus a = FromConsensus {unFromConsensus :: a} + deriving (Functor) + +instance Applicative FromConsensus where + pure = FromConsensus + FromConsensus f <*> FromConsensus a = FromConsensus (f a) diff --git a/ouroboros-network/changelog.d/20251016_141814_coot_dmq_signature_validation.md b/ouroboros-network/changelog.d/20251016_141814_coot_dmq_signature_validation.md new file mode 100644 index 00000000000..7994264a47f --- /dev/null +++ b/ouroboros-network/changelog.d/20251016_141814_coot_dmq_signature_validation.md @@ -0,0 +1,6 @@ +### Breaking + +- Ouroboros.Network.TxSubmission.Mempool.Simple API changes: + - `Mempool` is parametrised over `txid` and `tx` types + - `new` takes `tx -> txid` getter function + diff --git a/ouroboros-network/demo/ping-pong.hs b/ouroboros-network/demo/ping-pong.hs index b5109a8d81d..a3626b26485 100644 --- a/ouroboros-network/demo/ping-pong.hs +++ b/ouroboros-network/demo/ping-pong.hs @@ -57,7 +57,8 @@ main = do rmIfExists defaultLocalSocketAddrPath void serverPingPong - "pingpong2":"client":[] -> clientPingPong2 + "pingpong2":"client":[] -> clientPingPong2 False + "pingpong2":"client-flood":[] -> clientPingPong2 True "pingpong2":"server":[] -> do rmIfExists defaultLocalSocketAddrPath void serverPingPong2 @@ -69,7 +70,8 @@ instance ShowProxy PingPong where usage :: IO () usage = do - hPutStrLn stderr "usage: demo-ping-pong [pingpong|pingpong2] {client|server} [addr]" + hPutStrLn stderr $ "usage: demo-ping-pong pingpong {client|client-pipelined|server}\n" + ++ " demo-ping-pong pingpong2 {client|client-flood|server}" exitFailure defaultLocalSocketAddrPath :: FilePath @@ -143,7 +145,7 @@ clientPingPong pipelined = mkMiniProtocolCbFromPeerPipelined $ \_ctx -> ( contramap show stdoutTracer , codecPingPong - , void $ pingPongClientPeerPipelined (pingPongClientPipelinedMax 5) + , void $ pingPongClientPeerPipelined (pingPongClientPipelinedMax 15) ) | otherwise = @@ -151,7 +153,7 @@ clientPingPong pipelined = mkMiniProtocolCbFromPeer $ \_ctx -> ( contramap show stdoutTracer , codecPingPong - , pingPongClientPeer (pingPongClientCount 5) + , pingPongClientPeer (pingPongClientCount 15) ) @@ -213,8 +215,8 @@ demoProtocol1 pingPong pingPong' = ] -clientPingPong2 :: IO () -clientPingPong2 = +clientPingPong2 :: Bool -> IO () +clientPingPong2 flood = withIOManager $ \iomgr -> void $ do connectToNode (Snocket.localSnocket iomgr) @@ -235,12 +237,17 @@ clientPingPong2 = Mx.InitiatorMode addr LBS.ByteString IO () Void app = demoProtocol1 pingpong pingpong' + client :: PingPongClient IO () + client = if flood + then pingPongClientFlood + else pingPongClientCount 15 + pingpong = InitiatorProtocolOnly $ mkMiniProtocolCbFromPeer $ \_ctx -> ( contramap (show . (,) (1 :: Int)) tracer , codecPingPong - , pingPongClientPeer (pingPongClientCount 5) + , pingPongClientPeer client ) pingpong'= @@ -248,7 +255,7 @@ clientPingPong2 = mkMiniProtocolCbFromPeer $ \_ctx -> ( contramap (show . (,) (2 :: Int)) tracer , codecPingPong - , pingPongClientPeer (pingPongClientCount 5) + , pingPongClientPeer client ) diff --git a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index a6bd00592ec..a8ddfbe84c4 100644 --- a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -15,6 +15,9 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +#if !MIN_VERSION_QuickCheck(2,16,0) +{-# LANGUAGE PackageImports #-} +#endif -- for 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -64,6 +67,9 @@ import System.Random (StdGen, mkStdGen, split) import Text.Printf import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs index 22d07e6a33f..ec511a8ab53 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs @@ -1,5 +1,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} + +{-# LANGUAGE CPP #-} module Test.Ouroboros.Network.ConnectionManager.Timeouts ( verifyAllTimeouts @@ -39,6 +42,9 @@ import Data.Monoid (Sum (Sum)) import Text.Printf (printf) import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) import Ouroboros.Network.ConnectionManager.Core qualified as CM diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Utils.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Utils.hs index 573ce87ba89..ebe7f4860d8 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Utils.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Utils.hs @@ -1,6 +1,9 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + module Test.Ouroboros.Network.ConnectionManager.Utils where import Prelude hiding (read) @@ -10,6 +13,9 @@ import Ouroboros.Network.ConnectionManager.Core as CM import Ouroboros.Network.ConnectionManager.Types import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif verifyAbstractTransition :: AbstractTransition diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/InboundGovernor/Utils.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/InboundGovernor/Utils.hs index 171674153d2..d9ad578bf19 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/InboundGovernor/Utils.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/InboundGovernor/Utils.hs @@ -1,11 +1,17 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} + module Test.Ouroboros.Network.InboundGovernor.Utils where import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.InboundGovernor (RemoteSt (..)) diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs index adfd52df187..9b5087b72db 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs @@ -99,7 +99,7 @@ module Ouroboros.Network.BlockFetch -- * Re-export types used by 'BlockFetchConsensusInterface' , PraosFetchMode (..) , FetchMode (..) - , ChainComparison (..) + , FromConsensus (..) , SizeInBytes ) where @@ -122,7 +122,7 @@ import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientPolicy (..), readFetchClientsStateVars, readFetchClientsStatus, readPeerGSVs, setFetchClientContext) import Ouroboros.Network.BlockFetch.ConsensusInterface - (BlockFetchConsensusInterface (..), ChainComparison (..)) + (BlockFetchConsensusInterface (..), FromConsensus (..)) import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) import Ouroboros.Network.BlockFetch.State @@ -222,6 +222,8 @@ blockFetchLogic decisionTracer clientStateTracer peerSalt = bfcSalt, bulkSyncGracePeriod = gbfcGracePeriod bfcGenesisBFConfig, + plausibleCandidateChain, + compareCandidateChains, blockFetchSize } @@ -230,8 +232,7 @@ blockFetchLogic decisionTracer clientStateTracer FetchTriggerVariables { readStateCurrentChain = readCurrentChain, readStateCandidateChains = readCandidateChains, - readStatePeerStatus = readFetchClientsStatus registry, - readStateChainComparison = readChainComparison + readStatePeerStatus = readFetchClientsStatus registry } fetchNonTriggerVariables :: FetchNonTriggerVariables addr header block m diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Client.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Client.hs index 81f5612875f..ec6253cf643 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Client.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Client.hs @@ -41,9 +41,9 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.BlockFetch.ClientState (FetchClientContext (..), FetchClientPolicy (..), FetchClientStateVars (..), FetchRequest (..), - TraceFetchClientState (..), acknowledgeFetchRequest, - completeBlockDownload, completeFetchBatch, fetchClientCtxStateVars, - rejectedFetchBatch, startedFetchBatch) + FromConsensus (..), TraceFetchClientState (..), + acknowledgeFetchRequest, completeBlockDownload, completeFetchBatch, + fetchClientCtxStateVars, rejectedFetchBatch, startedFetchBatch) import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), PeerGSV (..)) import Ouroboros.Network.PeerSelection.PeerMetric.Type (FetchedMetricsTracer) @@ -267,7 +267,8 @@ blockFetchClient _version controlMessageSTM reportFetched -- Add the block to the chain DB, notifying of any new chains. addFetchedBlock (castPoint (blockPoint header)) block - let blockDelay = diffUTCTime now (headerForgeUTCTime header) + forgeTime <- atomically $ headerForgeUTCTime $ FromConsensus header + let blockDelay = diffUTCTime now forgeTime let hf = getHeaderFields header slotNo = headerFieldSlot hf diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/ClientState.hs index 74958ad58b0..3a386d2a184 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/ClientState.hs @@ -33,6 +33,7 @@ module Ouroboros.Network.BlockFetch.ClientState , TraceLabelPeer (..) , ChainRange (..) -- * Ancillary + , FromConsensus (..) , PeersOrder (..) ) where @@ -56,6 +57,7 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.Block (HasHeader, HeaderHash, MaxSlotNo (..), Point, blockPoint, castPoint) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FromConsensus (..)) import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), PeerGSV, SizeInBytes, calculatePeerFetchInFlightLimits) import Ouroboros.Network.ControlMessage (ControlMessageSTM, @@ -82,7 +84,7 @@ data FetchClientPolicy header block m = blockFetchSize :: header -> SizeInBytes, blockMatchesHeader :: header -> block -> Bool, addFetchedBlock :: Point block -> block -> m (), - headerForgeUTCTime :: header -> UTCTime + headerForgeUTCTime :: FromConsensus header -> STM m UTCTime } -- | A set of variables shared between the block fetch logic thread and each diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs index 67e7cbac1c3..5f086f097f6 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs @@ -33,8 +33,9 @@ import Data.Set qualified as Set import Data.Function (on) import Data.Hashable import Data.List as List (foldl', groupBy, sortBy, transpose) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (mapMaybe) import Data.Set (Set) +import GHC.Stack (HasCallStack) import Control.Exception (assert) import Control.Monad (guard) @@ -47,8 +48,8 @@ import Ouroboros.Network.Point (withOriginToMaybe) import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainComparison (..), - FetchMode (..), PraosFetchMode (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..), + PraosFetchMode (..)) import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), PeerGSV (..), SizeInBytes, calculatePeerFetchInFlightLimits, comparePeerGSV, comparePeerGSV', estimateExpectedResponseDuration, @@ -56,16 +57,25 @@ import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), data FetchDecisionPolicy header = FetchDecisionPolicy { - maxInFlightReqsPerPeer :: Word, -- A protocol constant. + maxInFlightReqsPerPeer :: Word, -- A protocol constant. - maxConcurrencyBulkSync :: Word, - maxConcurrencyDeadline :: Word, + maxConcurrencyBulkSync :: Word, + maxConcurrencyDeadline :: Word, decisionLoopIntervalGenesis :: DiffTime, - decisionLoopIntervalPraos :: DiffTime, - peerSalt :: Int, - bulkSyncGracePeriod :: DiffTime, + decisionLoopIntervalPraos :: DiffTime, + peerSalt :: Int, + bulkSyncGracePeriod :: DiffTime, - blockFetchSize :: header -> SizeInBytes + plausibleCandidateChain :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header -> Bool, + + compareCandidateChains :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header + -> Ordering, + + blockFetchSize :: header -> SizeInBytes } @@ -254,7 +264,6 @@ fetchDecisions HasHeader header, HeaderHash header ~ HeaderHash block) => FetchDecisionPolicy header - -> ChainComparison header -> PraosFetchMode -> AnchoredFragment header -> (Point block -> Bool) @@ -262,13 +271,11 @@ fetchDecisions -> [(AnchoredFragment header, PeerInfo header peer extra)] -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisions fetchDecisionPolicy@FetchDecisionPolicy { + plausibleCandidateChain, + compareCandidateChains, blockFetchSize, peerSalt } - ChainComparison { - plausibleCandidateChain, - compareCandidateChains - } fetchMode currentChain fetchedBlocks @@ -473,19 +480,8 @@ empty fetch range, but this is ok since we never request empty ranges. -- -- A 'ChainSuffix' must be non-empty, as an empty suffix, i.e. the candidate -- chain is equal to the current chain, would not be a plausible candidate. --- --- Additionally, we store the full candidate (with the same anchor as our --- current chain), as this is needed for comparing different candidates via --- 'compareCandidateChains'. -data ChainSuffix header = ChainSuffix { - -- | The suffix of the candidate after the intersection with the current - -- chain. - getChainSuffix :: !(AnchoredFragment header), - -- | The full candidate, characterized by having the same tip as - -- 'getChainSuffix' and the same anchor as our current chain. In particular, - -- 'getChainSuffix' is a suffix of 'getFullCandidate'. - getFullCandidate :: !(AnchoredFragment header) - } +newtype ChainSuffix header = + ChainSuffix { getChainSuffix :: AnchoredFragment header } {- We define the /chain suffix/ as the suffix of the candidate chain up until (but @@ -522,31 +518,25 @@ interested in this candidate at all. -- current chain. -- chainForkSuffix - :: HasHeader header - => AnchoredFragment header - -> AnchoredFragment header + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block -- ^ Current chain. + -> AnchoredFragment header -- ^ Candidate chain -> Maybe (ChainSuffix header) chainForkSuffix current candidate = case AF.intersect current candidate of Nothing -> Nothing - Just (currentChainPrefix, _, _, candidateSuffix) -> + Just (_, _, _, candidateSuffix) -> -- If the suffix is empty, it means the candidate chain was equal to -- the current chain and didn't fork off. Such a candidate chain is -- not a plausible candidate, so it must have been filtered out. assert (not (AF.null candidateSuffix)) $ - Just ChainSuffix { - getChainSuffix = candidateSuffix, - getFullCandidate = fullCandidate - } - where - fullCandidate = - fromMaybe (error "invariant violation of AF.intersect") $ - AF.join currentChainPrefix candidateSuffix - + Just (ChainSuffix candidateSuffix) selectForkSuffixes - :: HasHeader header - => AnchoredFragment header + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block -> [(FetchDecision (AnchoredFragment header), peerinfo)] -> [(FetchDecision (ChainSuffix header), peerinfo)] selectForkSuffixes current chains = @@ -760,11 +750,7 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz (equatingPair -- compare on probability band first, then preferred chain (==) - -- Precondition of 'compareCandidateChains' (used by - -- 'equateCandidateChains') is fulfilled as all - -- 'getFullCandidate's intersect pairwise (due to having the - -- same anchor as our current chain). - (equateCandidateChains `on` getFullCandidate) + (equateCandidateChains `on` getChainSuffix) `on` (\(band, chain, _fragments) -> (band, chain))))) . sortBy (descendingOrder @@ -773,10 +759,7 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz (comparingPair -- compare on probability band first, then preferred chain compare - -- Precondition of 'compareCandidateChains' is fulfilled as - -- all 'getFullCandidate's intersect pairwise (due to - -- having the same anchor as our current chain). - (compareCandidateChains `on` getFullCandidate) + (compareCandidateChains `on` getChainSuffix) `on` (\(band, chain, _fragments) -> (band, chain)))))) . map annotateProbabilityBand @@ -800,7 +783,7 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz | EQ <- compareCandidateChains chain1 chain2 = True | otherwise = False - chainHeadPoint (_,ChainSuffix {getChainSuffix = c},_) = AF.headPoint c + chainHeadPoint (_,ChainSuffix c,_) = AF.headPoint c prioritisePeerChains FetchModeBulkSync salt compareCandidateChains blockFetchSize = map (\(decision, peer) -> @@ -809,11 +792,7 @@ prioritisePeerChains FetchModeBulkSync salt compareCandidateChains blockFetchSiz (comparingRight (comparingPair -- compare on preferred chain first, then duration - -- - -- Precondition of 'compareCandidateChains' is fulfilled as - -- all 'getFullCandidate's intersect pairwise (due to having - -- the same anchor as our current chain). - (compareCandidateChains `on` getFullCandidate) + (compareCandidateChains `on` getChainSuffix) compare `on` (\(duration, chain, _fragments) -> (chain, duration))))) diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs index 4071a5d6fe3..db1aa588a2d 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs @@ -146,8 +146,8 @@ import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeersOrder (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainComparison(..), - ChainSelStarvation (..), FetchMode (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..), + FetchMode (..)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Cardano.Slotting.Slot (WithOrigin) @@ -167,7 +167,6 @@ fetchDecisionsGenesisM HeaderHash header ~ HeaderHash block, MonadMonotonicTime m) => Tracer m (TraceDecisionEvent peer header) -> FetchDecisionPolicy header - -> ChainComparison header -> AnchoredFragment header -> (Point block -> Bool) -- ^ Whether the block has been fetched (only if recent, i.e. within @k@). @@ -182,7 +181,6 @@ fetchDecisionsGenesisM fetchDecisionsGenesisM tracer fetchDecisionPolicy@FetchDecisionPolicy {bulkSyncGracePeriod} - chainComparison currentChain fetchedBlocks fetchedMaxSlotNo @@ -205,7 +203,6 @@ fetchDecisionsGenesisM let (theDecision, declines) = fetchDecisionsGenesis fetchDecisionPolicy - chainComparison currentChain fetchedBlocks fetchedMaxSlotNo @@ -319,7 +316,6 @@ fetchDecisionsGenesis , HeaderHash header ~ HeaderHash block ) => FetchDecisionPolicy header - -> ChainComparison header -> AnchoredFragment header -- ^ The current chain, anchored at the immutable tip. -> (Point block -> Bool) @@ -338,7 +334,6 @@ fetchDecisionsGenesis -- one @'FetchRequest' header@. fetchDecisionsGenesis fetchDecisionPolicy - chainComparison currentChain fetchedBlocks fetchedMaxSlotNo @@ -351,7 +346,7 @@ fetchDecisionsGenesis ) <- MaybeT $ selectTheCandidate - chainComparison + fetchDecisionPolicy currentChain candidatesAndPeers @@ -428,7 +423,7 @@ dropAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = selectTheCandidate :: forall header peerInfo. HasHeader header - => ChainComparison header + => FetchDecisionPolicy header -> AnchoredFragment header -- ^ The current chain. -> [(AnchoredFragment header, peerInfo)] @@ -441,7 +436,7 @@ selectTheCandidate -- selected candidate that we choose to sync from and a list of peers that -- are still in the race to serve that candidate. selectTheCandidate - ChainComparison {compareCandidateChains, plausibleCandidateChain} + FetchDecisionPolicy {compareCandidateChains, plausibleCandidateChain} currentChain = separateDeclinedAndStillInRace -- Select the suffix up to the intersection with the current chain. This can @@ -462,16 +457,13 @@ selectTheCandidate case inRace of [] -> pure Nothing _ : _ -> do - -- Precondition of 'compareCandidateChains' is fulfilled as all - -- 'getFullCandidate's intersect pairwise (due to having the same - -- anchor as our current chain). let maxChainOn f c0 c1 = case compareCandidateChains (f c0) (f c1) of LT -> c1 _ -> c0 -- maximumBy yields the last element in case of a tie while we -- prefer the first one chainSfx = fst $ - List.foldl1' (maxChainOn (getFullCandidate . fst)) inRace + List.foldl1' (maxChainOn (getChainSuffix . fst)) inRace pure $ Just (chainSfx, inRace) -- | Given _the_ candidate fragment to sync from, and a list of peers (with diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/State.hs index 62d0f4a3010..1ee5718b6e5 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/State.hs @@ -43,9 +43,8 @@ import Ouroboros.Network.BlockFetch.ClientState (FetchClientStateVars (..), FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..), PeersOrder (..), TraceFetchClientState (..), TraceLabelPeer (..), addNewFetchRequest, readFetchClientState) -import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainComparison (..), - ChainSelStarvation, FetchMode (..), Fingerprint (..), - WithFingerprint (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation, + FetchMode (..)) import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecisionPolicy (..), FetchDecline (..), PeerInfo, PraosFetchMode (..), fetchDecisions) @@ -228,8 +227,7 @@ fetchDecisionsForStateSnapshot fetchStateFetchedBlocks, fetchStateFetchedMaxSlotNo, fetchStateFetchMode, - fetchStateChainSelStarvation, - fetchStateChainComparison + fetchStateChainSelStarvation } peersOrderHandlers = assert ( Map.keysSet fetchStatePeerChains @@ -242,7 +240,6 @@ fetchDecisionsForStateSnapshot PraosFetchMode fetchMode -> pure $ fetchDecisions fetchDecisionPolicy - fetchStateChainComparison fetchMode fetchStateCurrentChain fetchStateFetchedBlocks @@ -252,7 +249,6 @@ fetchDecisionsForStateSnapshot fetchDecisionsGenesisM tracer fetchDecisionPolicy - fetchStateChainComparison fetchStateCurrentChain fetchStateFetchedBlocks fetchStateFetchedMaxSlotNo @@ -306,8 +302,7 @@ fetchLogicIterationAct clientStateTracer FetchDecisionPolicy{blockFetchSize} data FetchTriggerVariables peer header m = FetchTriggerVariables { readStateCurrentChain :: STM m (AnchoredFragment header), readStateCandidateChains :: STM m (Map peer (AnchoredFragment header)), - readStatePeerStatus :: STM m (Map peer (PeerFetchStatus header)), - readStateChainComparison :: STM m (WithFingerprint (ChainComparison header)) + readStatePeerStatus :: STM m (Map peer (PeerFetchStatus header)) } -- | STM actions to read various state variables that the fetch logic uses. @@ -329,7 +324,6 @@ data FetchStateFingerprint peer header block = !(Maybe (Point block)) !(Map peer (Point header)) !(Map peer (PeerFetchStatus header)) - !Fingerprint -- ^ From 'ChainComparison' deriving Eq initialFetchStateFingerprint :: FetchStateFingerprint peer header block @@ -338,19 +332,17 @@ initialFetchStateFingerprint = Nothing Map.empty Map.empty - (Fingerprint 0) updateFetchStateFingerprintPeerStatus :: Ord peer => [(peer, PeerFetchStatus header)] -> FetchStateFingerprint peer header block -> FetchStateFingerprint peer header block updateFetchStateFingerprintPeerStatus statuses' - (FetchStateFingerprint current candidates statuses fpChainComp) = + (FetchStateFingerprint current candidates statuses) = FetchStateFingerprint current candidates (Map.union (Map.fromList statuses') statuses) -- left overrides right - fpChainComp -- | -- @@ -367,8 +359,7 @@ data FetchStateSnapshot peer header block m = FetchStateSnapshot { fetchStateFetchedBlocks :: Point block -> Bool, fetchStateFetchMode :: FetchMode, fetchStateFetchedMaxSlotNo :: MaxSlotNo, - fetchStateChainSelStarvation :: ChainSelStarvation, - fetchStateChainComparison :: ChainComparison header + fetchStateChainSelStarvation :: ChainSelStarvation } readStateVariables :: (MonadSTM m, Eq peer, @@ -387,11 +378,10 @@ readStateVariables FetchTriggerVariables{..} fetchStateFingerprint = do -- Read all the trigger state variables - fetchStateCurrentChain <- readStateCurrentChain - fetchStatePeerChains <- readStateCandidateChains - fetchStatePeerStatus <- readStatePeerStatus - chainComparison <- readStateChainComparison - gracePeriodExpired <- LazySTM.readTVar gracePeriodTVar + fetchStateCurrentChain <- readStateCurrentChain + fetchStatePeerChains <- readStateCandidateChains + fetchStatePeerStatus <- readStatePeerStatus + gracePeriodExpired <- LazySTM.readTVar gracePeriodTVar -- Construct the change detection fingerprint let !fetchStateFingerprint' = @@ -399,7 +389,6 @@ readStateVariables FetchTriggerVariables{..} (Just (castPoint (AF.headPoint fetchStateCurrentChain))) (Map.map AF.headPoint fetchStatePeerChains) fetchStatePeerStatus - (getFingerprint chainComparison) -- Check the fingerprint changed, or block and wait until it does check (gracePeriodExpired || fetchStateFingerprint' /= fetchStateFingerprint) @@ -423,8 +412,7 @@ readStateVariables FetchTriggerVariables{..} fetchStateFetchedBlocks, fetchStateFetchMode, fetchStateFetchedMaxSlotNo, - fetchStateChainSelStarvation, - fetchStateChainComparison = forgetFingerprint chainComparison + fetchStateChainSelStarvation } return (fetchStateSnapshot, gracePeriodExpired, fetchStateFingerprint') diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs index 1175259bacd..a59a4557cb0 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs @@ -16,6 +16,7 @@ module Ouroboros.Network.Diffusion , runM , mkInterfaces , socketAddressType + , withIOManager , module Ouroboros.Network.Diffusion.Types ) where diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs index 94a4bece425..3e2e871582d 100644 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs +++ b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs @@ -1,62 +1,85 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} -- | The module should be imported qualified. -- module Ouroboros.Network.TxSubmission.Mempool.Simple - ( Mempool (..) + ( MempoolAddFail + , Mempool (..) + , MempoolSeq (..) + , MempoolWriter (..) , empty , new , read , getReader , getWriter + , writerAdapter ) where import Prelude hiding (read, seq) import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (when) -import Control.Monad.Class.MonadThrow - -import Data.Bifunctor (bimap) -import Data.Either (partitionEithers) +import Control.DeepSeq +import Control.Exception (assert) +import Control.Monad.Trans.Except +import Data.Bifunctor (bimap, first, second) +import Data.Either import Data.Foldable (toList) import Data.Foldable qualified as Foldable -import Data.Function (on) -import Data.List (find, nubBy) +import Data.List (find) import Data.Maybe (isJust) import Data.Sequence (Seq) import Data.Sequence qualified as Seq +import Data.Set (Set) import Data.Set qualified as Set -import Data.Typeable (Typeable) +import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..)) import Ouroboros.Network.SizeInBytes import Ouroboros.Network.TxSubmission.Inbound.V2.Types import Ouroboros.Network.TxSubmission.Mempool.Reader +data MempoolSeq txid tx = MempoolSeq { + mempoolSet :: !(Set txid), + -- ^ cached set of `txid`s in the mempool + mempoolSeq :: !(Seq tx) + -- ^ sequence of all `tx`s + } + -- | A simple in-memory mempool implementation. -- -newtype Mempool m tx = Mempool (StrictTVar m (Seq tx)) +newtype Mempool m txid tx = Mempool (StrictTVar m (MempoolSeq txid tx)) -empty :: MonadSTM m => m (Mempool m tx) -empty = Mempool <$> newTVarIO Seq.empty +empty :: MonadSTM m => m (Mempool m txid tx) +empty = Mempool <$> newTVarIO (MempoolSeq Set.empty Seq.empty) -new :: MonadSTM m - => [tx] - -> m (Mempool m tx) -new = fmap Mempool - . newTVarIO - . Seq.fromList +new :: ( MonadSTM m + , Ord txid + ) + => (tx -> txid) + -> [tx] + -> m (Mempool m txid tx) +new getTxId txs = + fmap Mempool + . newTVarIO + $ MempoolSeq { mempoolSet = Set.fromList (getTxId <$> txs), + mempoolSeq = Seq.fromList txs + } -read :: MonadSTM m => Mempool m tx -> m [tx] -read (Mempool mempool) = toList <$> readTVarIO mempool +read :: MonadSTM m => Mempool m txid tx -> m [tx] +read (Mempool mempool) = toList . mempoolSeq <$> readTVarIO mempool getReader :: forall tx txid m. @@ -65,7 +88,7 @@ getReader :: forall tx txid m. ) => (tx -> txid) -> (tx -> SizeInBytes) - -> Mempool m tx + -> Mempool m txid tx -> TxSubmissionMempoolReader txid tx Int m getReader getTxId getTxSize (Mempool mempool) = -- Using `0`-based index. `mempoolZeroIdx = -1` so that @@ -75,7 +98,7 @@ getReader getTxId getTxSize (Mempool mempool) = } where mempoolGetSnapshot :: STM m (MempoolSnapshot txid tx Int) - mempoolGetSnapshot = getSnapshot <$> readTVar mempool + mempoolGetSnapshot = getSnapshot . mempoolSeq <$> readTVar mempool getSnapshot :: Seq tx -> MempoolSnapshot txid tx Int @@ -91,66 +114,98 @@ getReader getTxId getTxSize (Mempool mempool) = f idx tx = (getTxId tx, idx, getTxSize tx) -data InvalidTxsError where - InvalidTxsError :: forall txid failure. - ( Typeable txid - , Typeable failure - , Show txid - , Show failure - ) - => [(txid, failure)] - -> InvalidTxsError - -deriving instance Show InvalidTxsError -instance Exception InvalidTxsError - +-- | type of mempool validation errors which are non-fatal +-- +data family MempoolAddFail tx --- | A simple mempool writer. +-- | A mempool writer which generalizes the tx submission mempool writer +-- TODO: We could replace TxSubmissionMempoolWriter with this at some point +-- +data MempoolWriter txid tx idx m = + MempoolWriter { + + -- | Compute the transaction id from a transaction. + -- + -- This is used in the protocol handler to verify a full transaction + -- matches a previously given transaction id. + -- + txId :: tx -> txid, + + -- | Supply a batch of transactions to the mempool. They are either + -- accepted or rejected individually, but in the order supplied. + -- + -- The 'txid's of all transactions that were added successfully are + -- returned. + mempoolAddTxs + :: [tx] + -> m (Either (txid, MempoolAddFail tx) [(txid, SubmitResult (MempoolAddFail tx))]) + } + + +-- | A mempool writer with validation harness +-- PRECONDITION: no duplicates given to mempoolAddTxs -- -getWriter :: forall tx txid ctx failure m. +getWriter :: forall tx txid ctx m. ( MonadSTM m - , MonadThrow m + -- TODO: + -- , NFData txid + -- , NFData tx + -- , NFData (MempoolAddFail tx) , Ord txid - , Typeable txid - , Typeable failure - , Show txid - , Show failure ) => (tx -> txid) -- ^ get txid of a tx -> m ctx - -- ^ monadic validation ctx - -> (ctx -> tx -> Either failure ()) - -- ^ validate a tx, any failing `tx` throws an exception. - -> (failure -> Bool) - -- ^ return `True` when a failure should throw an exception - -> Mempool m tx - -> TxSubmissionMempoolWriter txid tx Int m -getWriter getTxId getValidationCtx validateTx failureFilterFn (Mempool mempool) = - TxSubmissionMempoolWriter { - txId = getTxId, - - mempoolAddTxs = \txs -> do - ctx <- getValidationCtx - (invalidTxIds, validTxs) <- atomically $ do - mempoolTxs <- readTVar mempool - let -- TODO: set of current ids should be constructed incrementally, - -- e.g. it should be part of mempoolTxs - currentIds = Set.fromList (map getTxId (toList mempoolTxs)) - (invalidTxIds, validTxs) = - bimap (filter (failureFilterFn . snd)) - (nubBy (on (==) getTxId)) - . partitionEithers - . map (\tx -> case validateTx ctx tx of - Left e -> Left (getTxId tx, e) - Right _ -> Right tx - ) - . filter (\tx -> getTxId tx `Set.notMember` currentIds) - $ txs - mempoolTxs' = Foldable.foldl' (Seq.|>) mempoolTxs validTxs - writeTVar mempool mempoolTxs' - return (invalidTxIds, map getTxId validTxs) - when (not (null invalidTxIds)) $ - throwIO (InvalidTxsError invalidTxIds) - return validTxs - } + -- ^ acquire validation context + -> ( [tx] + -> ctx + -> ExceptT (tx, MempoolAddFail tx) m + [(tx, Either (MempoolAddFail tx) ())]) + -- ^ validation function which should evaluate its result to normal form + -- esp. if it is 'expensive' + -> MempoolAddFail tx + -- ^ replace duplicates + -> Mempool m txid tx + -> MempoolWriter txid tx Int m +getWriter getTxId acquireCtx validateTxs duplicateFail (Mempool mempool) = + MempoolWriter { + txId = getTxId, + + mempoolAddTxs = \txs -> assert (not . null $ txs) $ do + ctx <- acquireCtx + first (first getTxId) + <$> runExceptT do + -- todo probably should force the results before entering the atomically block + !vTxs <- zipWith ((,) . getTxId) txs <$> validateTxs txs ctx + + ExceptT . atomically $ do + MempoolSeq { mempoolSet, mempoolSeq } <- readTVar mempool + let result = + [if duplicate then + Left (txid, duplicateFail) + else + bimap ((txid,)) (const (txid, tx)) eResult + | (txid, (tx, eResult)) <- vTxs + , let duplicate = txid `Set.member` mempoolSet + ] + (validIds, validTxs) = unzip . rights $ result + mempoolTxs' = MempoolSeq { + mempoolSet = Set.union mempoolSet (Set.fromList validIds), + mempoolSeq = Foldable.foldl' (Seq.|>) mempoolSeq validTxs + } + writeTVar mempool mempoolTxs' + return . Right $ either (second SubmitFail) (second (const SubmitSuccess)) <$> result + } + + +-- | Takes the general mempool writer defined here +-- and adapts it to the API of the tx submission mempool writer +-- to avoid more breaking changes for now. +-- +writerAdapter :: (Functor m) + => MempoolWriter txid tx idx m + -> TxSubmissionMempoolWriter txid tx idx m +writerAdapter MempoolWriter { txId, mempoolAddTxs } = undefined + TxSubmissionMempoolWriter { txId, mempoolAddTxs = adapter } + where + adapter = fmap (either (const []) (fmap fst)) . mempoolAddTxs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index fa18938acb1..e75f05f7802 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -470,6 +470,9 @@ test-suite tests-lib-tests library framework-tests-lib import: ghc-options + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + visibility: public hs-source-dirs: framework/tests-lib exposed-modules: @@ -481,7 +484,7 @@ library framework-tests-lib Test.Ouroboros.Network.RawBearer.Utils build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, cborg, @@ -492,12 +495,16 @@ library framework-tests-lib io-sim, network-mux, ouroboros-network:{api, framework, tests-lib}, + quickcheck-monoids, random, serialise, typed-protocols:{typed-protocols, examples}, test-suite framework-sim-tests import: ghc-options + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: framework/sim-tests @@ -509,7 +516,7 @@ test-suite framework-sim-tests Test.Simulation.Network.Snocket build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, cborg, @@ -523,6 +530,7 @@ test-suite framework-sim-tests pretty-simple, psqueues, quickcheck-instances, + quickcheck-monoids, quiet, random, serialise, @@ -551,7 +559,7 @@ test-suite framework-io-tests Test.Ouroboros.Network.Socket build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, contra-tracer, @@ -819,10 +827,13 @@ test-suite protocols-tests -- Simulation Test Library library ouroboros-network-tests-lib import: ghc-options-tests + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + visibility: public hs-source-dirs: tests/lib build-depends: - QuickCheck >=2.16, + QuickCheck, aeson, array, base >=4.14 && <4.22, @@ -845,6 +856,7 @@ library ouroboros-network-tests-lib nothunks, ouroboros-network:{ouroboros-network, api, api-tests-lib, framework, framework-tests-lib, protocols, protocols-tests-lib, tests-lib}, pretty-simple, + quickcheck-monoids, random, serialise, splitmix, @@ -853,6 +865,7 @@ library ouroboros-network-tests-lib tasty-quickcheck, text, time >=1.9.1 && <1.14, + transformers-except, typed-protocols, exposed-modules: @@ -879,6 +892,9 @@ library ouroboros-network-tests-lib Test.Ouroboros.Network.TxSubmission.TxLogic Test.Ouroboros.Network.TxSubmission.Types + ghc-options: + -Wno-unused-packages + -- Simulation tests, and IO tests which don't require native system calls. -- (i.e. they don't require system call API provided by `Win32-network` or -- `network` dependency). test-suite sim-tests @@ -915,7 +931,7 @@ test-suite ouroboros-network-io-tests Test.Ouroboros.Network.Socket build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, cborg, diff --git a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs index 6bb7bba12a0..7d5c3f207cd 100644 --- a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs +++ b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs @@ -46,7 +46,8 @@ import Ouroboros.Network.Mock.ChainGenerators () import Ouroboros.Network.Mock.ConcreteBlock (Block) import Ouroboros.Network.Protocol.LocalStateQuery.Client -import Ouroboros.Network.Protocol.LocalStateQuery.Codec +import Ouroboros.Network.Protocol.LocalStateQuery.Codec hiding (Some (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Codec qualified as LocalStateQuery import Ouroboros.Network.Protocol.LocalStateQuery.Direct import Ouroboros.Network.Protocol.LocalStateQuery.Examples import Ouroboros.Network.Protocol.LocalStateQuery.Server @@ -54,7 +55,7 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type import Test.Ouroboros.Network.Protocol.Utils -import Test.QuickCheck as QC hiding (Result, Some (Some)) +import Test.QuickCheck as QC hiding (Result) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Text.Show.Functions () @@ -386,10 +387,10 @@ codec = encodeQuery :: Query result -> CBOR.Encoding encodeQuery GetTheLedgerState = Serialise.encode () - decodeQuery :: forall s . CBOR.Decoder s (Some Query) + decodeQuery :: forall s . CBOR.Decoder s (LocalStateQuery.Some Query) decodeQuery = do () <- Serialise.decode - return $ Some GetTheLedgerState + return $ LocalStateQuery.Some GetTheLedgerState encodeResult :: Query result -> result -> CBOR.Encoding encodeResult GetTheLedgerState = Serialise.encode diff --git a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/TxSubmission2/Test.hs b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/TxSubmission2/Test.hs index 6de56ad4951..6c0fc651fc0 100644 --- a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/TxSubmission2/Test.hs +++ b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/TxSubmission2/Test.hs @@ -435,8 +435,8 @@ labelMsg (AnyMessage msg) = label (case msg of MsgInit -> "MsgInit" MsgRequestTxIds {} -> "MsgRequestTxIds" - MsgReplyTxIds as -> "MsgReplyTxIds " ++ renderRanges 3 (length as) - MsgRequestTxs as -> "MsgRequestTxs " ++ renderRanges 3 (length as) - MsgReplyTxs as -> "MsgReplyTxs " ++ renderRanges 3 (length as) + MsgReplyTxIds as -> "MsgReplyTxIds " ++ renderRanges 25 (length as) + MsgRequestTxs as -> "MsgRequestTxs " ++ renderRanges 25 (length as) + MsgReplyTxs as -> "MsgReplyTxs " ++ renderRanges 25 (length as) MsgDone -> "MsgDone" ) diff --git a/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs index 30a9cfde718..9b74d0b544b 100644 --- a/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -52,7 +52,6 @@ import Ouroboros.Network.Protocol.BlockFetch.Server import Ouroboros.Network.Protocol.BlockFetch.Type import Ouroboros.Network.Util.ShowProxy -import Ouroboros.Network.BlockFetch.ConsensusInterface (initialWithFingerprint) import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) import Ouroboros.Network.Mock.ConcreteBlock @@ -151,8 +150,8 @@ blockFetchExample0 fetchMode decisionTracer clientStateTracer clientMsgTracer }) >> return () - headerForgeUTCTime = - convertSlotToTimeForTestsAssumingNoHardFork . headerSlot + headerForgeUTCTime (FromConsensus x) = + pure $ convertSlotToTimeForTestsAssumingNoHardFork (blockSlot x) driver :: TestFetchedBlockHeap m Block -> m () driver blockHeap = do @@ -265,8 +264,8 @@ blockFetchExample1 fetchMode decisionTracer clientStateTracer clientMsgTracer }) >> return () - headerForgeUTCTime = - convertSlotToTimeForTestsAssumingNoHardFork . headerSlot + headerForgeUTCTime (FromConsensus x) = + pure $ convertSlotToTimeForTestsAssumingNoHardFork (blockSlot x) -- | Terminates after 1 second per block in the candidate chains. downloadTimer :: m () @@ -280,7 +279,7 @@ blockFetchExample1 fetchMode decisionTracer clientStateTracer clientMsgTracer sampleBlockFetchPolicy1 :: (MonadSTM m, HasHeader header, HasHeader block) => FetchMode - -> (header -> UTCTime) + -> (forall x. HasHeader x => FromConsensus x -> STM m UTCTime) -> TestFetchedBlockHeap m block -> AnchoredFragment header -> Map peer (AnchoredFragment header) @@ -298,10 +297,8 @@ sampleBlockFetchPolicy1 fetchMode headerFieldsForgeUTCTime blockHeap currentChai getTestFetchedBlocks blockHeap, mkAddFetchedBlock = pure $ addTestFetchedBlock blockHeap, - readChainComparison = pure $ initialWithFingerprint ChainComparison { - plausibleCandidateChain, - compareCandidateChains - }, + plausibleCandidateChain, + compareCandidateChains, blockFetchSize = \_ -> 2000, blockMatchesHeader = \_ _ -> True, diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/BlockFetch.hs index 4bccc937775..7de81fc2e1c 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/BlockFetch.hs @@ -790,7 +790,7 @@ unit_bracketSyncWithFetchClient step = do dummyPolicy :: forall b h m. (MonadSTM m) => STM m (FetchClientPolicy h b m) dummyPolicy = let addFetchedBlock _ _ = return () - forgeTime _ = read "2000-01-01 00:00:00 UTC" + forgeTime _ = return (read "2000-01-01 00:00:00 UTC") bfSize _ = 1024 matchesHeader _ _ = True in pure $ FetchClientPolicy diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs index a8f7ad26fc7..f7348b4fb25 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -75,8 +75,7 @@ import Ouroboros.Network.Block (MaxSlotNo (..), maxSlotNoFromWithOrigin, pointSlot) import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.ConsensusInterface - (ChainSelStarvation (ChainSelStarvationEndedAt), - initialWithFingerprint) + (ChainSelStarvation (ChainSelStarvationEndedAt)) import Ouroboros.Network.ConnectionManager.State (ConnStateIdSupply) import Ouroboros.Network.ConnectionManager.Types (DataFlow (..)) import Ouroboros.Network.Diffusion qualified as Diffusion @@ -405,10 +404,8 @@ run blockGeneratorArgs ni na pure $ \_p b -> atomically (addBlock b (nkChainDB nodeKernel)), - readChainComparison = pure $ initialWithFingerprint ChainComparison { - plausibleCandidateChain, - compareCandidateChains - }, + plausibleCandidateChain, + compareCandidateChains, blockFetchSize = \_ -> 1000, blockMatchesHeader = \_ _ -> True, @@ -422,8 +419,9 @@ run blockGeneratorArgs ni na plausibleCandidateChain cur candidate = AF.headBlockNo candidate > AF.headBlockNo cur - headerForgeUTCTime = - convertSlotToTimeForTestsAssumingNoHardFork . headerSlot + headerForgeUTCTime (FromConsensus hdr) = + pure $ + convertSlotToTimeForTestsAssumingNoHardFork (headerSlot hdr) compareCandidateChains c1 c2 = AF.headBlockNo c1 `compare` AF.headBlockNo c2 diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs index 6ab63cd8955..f6a6065565d 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -310,7 +310,7 @@ data NodeKernel header block s txid m = NodeKernel { :: StrictTVar m (PublicPeerSelectionState NtNAddr), nkMempool - :: Mempool m (Tx txid), + :: Mempool m txid (Tx txid), nkTxChannelsVar :: TxChannelsVar m NtNAddr txid (Tx txid), @@ -325,6 +325,7 @@ data NodeKernel header block s txid m = NodeKernel { newNodeKernel :: ( MonadSTM m , Strict.MonadMVar m , RandomGen rng + , Ord txid , Eq txid ) => rng @@ -426,6 +427,7 @@ withNodeKernelThread , HasFullHeader block , RandomGen seed , Eq txid + , Ord txid ) => NtNAddr -- ^ just for naming a thread diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs index 297b9b02074..3e5fe31139f 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 908 @@ -49,6 +50,9 @@ import NoThunks.Class import Test.Ouroboros.Network.Data.Script import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV1.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV1.hs index bc154f5762b..a28dec40e2f 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV1.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV1.hs @@ -119,7 +119,7 @@ txSubmissionSimulation tracer maxUnacked outboundTxs return (inmp, outmp) where - outboundPeer :: Mempool m (Tx txid) -> TxSubmissionClient txid (Tx txid) m () + outboundPeer :: Mempool m txid (Tx txid) -> TxSubmissionClient txid (Tx txid) m () outboundPeer outboundMempool = txSubmissionOutbound nullTracer @@ -128,7 +128,7 @@ txSubmissionSimulation tracer maxUnacked outboundTxs (maxBound :: TestVersion) controlMessageSTM - inboundPeer :: Mempool m (Tx txid) -> TxSubmissionServerPipelined txid (Tx txid) m () + inboundPeer :: Mempool m txid (Tx txid) -> TxSubmissionServerPipelined txid (Tx txid) m () inboundPeer inboundMempool = txSubmissionInbound nullTracer diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index c12e9ca59dd..f08ddb1d5db 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -4,11 +4,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-orphans #-} module Test.Ouroboros.Network.TxSubmission.AppV2 (tests) where @@ -63,6 +66,9 @@ import Test.Ouroboros.Network.TxSubmission.Types import Test.Ouroboros.Network.Utils hiding (debugTracer) import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index f15d6b06749..4b8381f8c74 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -7,10 +7,13 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-orphans #-} module Test.Ouroboros.Network.TxSubmission.TxLogic @@ -60,6 +63,9 @@ import Test.QuickCheck import Test.QuickCheck.Function (apply) import Test.QuickCheck.Gen (Gen (..)) import Test.QuickCheck.Random (QCGen (..)) +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Text.Pretty.Simple diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs index e686cc706f1..2d117a52018 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs @@ -7,6 +7,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Test.Ouroboros.Network.TxSubmission.Types ( Tx (..) @@ -42,6 +43,7 @@ import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim hiding (SimResult) +import Control.Monad.Trans.Except.Extra import Control.Tracer (Tracer (..), showTracing, traceWith) import Codec.CBOR.Decoding qualified as CBOR @@ -58,7 +60,7 @@ import Ouroboros.Network.Protocol.TxSubmission2.Codec import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Network.TxSubmission.Inbound.V1 import Ouroboros.Network.TxSubmission.Mempool.Reader -import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool) +import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool, MempoolAddFail) import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool import Ouroboros.Network.Util.ShowProxy @@ -77,6 +79,8 @@ data Tx txid = Tx { } deriving (Eq, Ord, Show, Generic, NFData) +data instance MempoolAddFail (Tx txid) = TxFail + instance NoThunks txid => NoThunks (Tx txid) instance ShowProxy txid => ShowProxy (Tx txid) where showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) @@ -103,13 +107,14 @@ maxTxSize = 65536 type TxId = Int -emptyMempool :: MonadSTM m => m (Mempool m (Tx txid)) +emptyMempool :: MonadSTM m => m (Mempool m txid (Tx txid)) emptyMempool = Mempool.empty -newMempool :: MonadSTM m => [Tx txid] -> m (Mempool m (Tx txid)) -newMempool = Mempool.new +newMempool :: (MonadSTM m, Ord txid) + => [Tx txid] -> m (Mempool m txid (Tx txid)) +newMempool = Mempool.new getTxId -readMempool :: MonadSTM m => Mempool m (Tx txid) -> m [Tx txid] +readMempool :: MonadSTM m => Mempool m txid (Tx txid) -> m [Tx txid] readMempool = Mempool.read getMempoolReader :: forall txid m. @@ -117,7 +122,7 @@ getMempoolReader :: forall txid m. , Eq txid , Show txid ) - => Mempool m (Tx txid) + => Mempool m txid (Tx txid) -> TxSubmissionMempoolReader txid (Tx txid) Int m getMempoolReader = Mempool.getReader getTxId getTxAdvSize @@ -130,15 +135,16 @@ getMempoolWriter :: forall txid m. , Typeable txid , Show txid ) - => Mempool m (Tx txid) + => Mempool m txid (Tx txid) -> TxSubmissionMempoolWriter txid (Tx txid) Int m -getMempoolWriter = Mempool.getWriter getTxId +getMempoolWriter = Mempool.writerAdapter + . Mempool.getWriter getTxId (pure ()) - (\_ tx -> if getTxValid tx - then Right () - else Left () + (\[tx] _ctx -> if getTxValid tx + then right [(tx, Right ())] + else left (tx, TxFail) ) - (\_ -> False) + TxFail txSubmissionCodec2 :: MonadST m diff --git a/quickcheck-monoids/CHANGELOG.md b/quickcheck-monoids/CHANGELOG.md new file mode 100644 index 00000000000..faa779ee3aa --- /dev/null +++ b/quickcheck-monoids/CHANGELOG.md @@ -0,0 +1,20 @@ +# Revision history for quickcheck-monoids + +## 0.1.0.3 -- 2025-08-27 + +* Somewhat compatible with `QuickCheck-2.16`: `QuickCheck` is also defining + `Test.QuickCheck.Monoids` module. + +## 0.1.0.2 -- 2025-06-28 + +* Package is deprecated, use `QuickCheck >= 2.16` which provides `Every` and + `Some` monoids. + +## 0.1.0.1 -- 2024-08-07 + +* Make it build with ghc-9.10 + * fix base upper bound + +## 0.1.0.0 -- 2024-06-07 + +* First version. Released on an unsuspecting world. diff --git a/quickcheck-monoids/quickcheck-monoids.cabal b/quickcheck-monoids/quickcheck-monoids.cabal new file mode 100644 index 00000000000..d0e4f45495d --- /dev/null +++ b/quickcheck-monoids/quickcheck-monoids.cabal @@ -0,0 +1,57 @@ +cabal-version: 3.0 +name: quickcheck-monoids +version: 0.1.0.3 +synopsis: QuickCheck monoids +description: All and Any monoids for `Testable` instances based on `.&&.` and `.||.`. +license: Apache-2.0 +license-files: + LICENSE + NOTICE + +author: Marcin Szamotulski +maintainer: coot@coot.me +category: Testing +copyright: 2024 Input Output Global Inc (IOG) +build-type: Simple +extra-doc-files: CHANGELOG.md +extra-source-files: README.md + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Test.QuickCheck.Monoids + build-depends: + QuickCheck, + base <4.22, + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wunused-packages + +test-suite quickcheck-monoids-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + QuickCheck, + base, + quickcheck-monoids, + tasty, + tasty-quickcheck, + + ghc-options: + -Wall + -rtsopts diff --git a/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs new file mode 100644 index 00000000000..fb6abf8b467 --- /dev/null +++ b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Monoids using `.&&.` and `.||.`. +-- +-- They satisfy monoid laws with respect to the `isSuccess` unless one is using +-- `checkCoverage` (see test for a counterexample). +-- +module Test.QuickCheck.Monoids +#if !MIN_VERSION_QuickCheck(2,16,0) + ( type Every + , All(Every, getEvery, ..) + , type Some + , Any(Some, getSome, ..) +#else + ( All (..) + , Any (..) + , Every (..) + , Some (..) +#endif + ) where + +import Data.List.NonEmpty as NonEmpty +import Data.Semigroup (Semigroup (..)) +import Test.QuickCheck + +-- | Conjunction monoid build with `.&&.`. +-- +-- Use `property @All` as an accessor which doesn't leak +-- existential variables. +-- +data All = forall p. Testable p => All { getAll :: p } + +#if !MIN_VERSION_QuickCheck(2,16,0) +type Every = All + +pattern Every :: () + => Testable p + => p + -> All +pattern Every { getEvery } = All getEvery +#endif + +instance Testable All where + property (All p) = property p + +instance Semigroup All where + All p <> All p' = All (p .&&. p') + sconcat = All . conjoin . NonEmpty.toList + +instance Monoid All where + mempty = All True + mconcat = All . conjoin + + +-- | Disjunction monoid build with `.||.`. +-- +-- Use `property @Any` as an accessor which doesn't leak +-- existential variables. +-- +data Any = forall p. Testable p => Any { getAny :: p } + +#if !MIN_VERSION_QuickCheck(2,16,0) +type Some = Any + +pattern Some :: () + => Testable p + => p + -> Any +pattern Some { getSome } = Any getSome +#endif + +instance Testable Any where + property (Any p) = property p + +instance Semigroup Any where + Any p <> Any p' = Any (p .||. p') + sconcat = Any . disjoin . NonEmpty.toList + +instance Monoid Any where + mempty = Any False + mconcat = Any . disjoin diff --git a/scripts/ci/cabal.project.local.Nix.Windows b/scripts/ci/cabal.project.local.Nix.Windows new file mode 100644 index 00000000000..af847f4bb59 --- /dev/null +++ b/scripts/ci/cabal.project.local.Nix.Windows @@ -0,0 +1,32 @@ +max-backjumps: 5000 +reorder-goals: True +tests: True +benchmarks: True + +-- IPv6 and nothunks tests are DISABLED on Windows + +program-options + ghc-options: -fno-ignore-asserts -Werror + +package strict-checked-vars + flags: -checktvarinvariants -checkmvarinvariants + +package ntp-client + flags: +demo + +package network-mux + flags: -ipv6 + +package ouroboros-network + flags: +asserts -ipv6 + +-- +-- cddl is disabled on Windows due to missing build tool support in cross +-- compilation +-- + +package dmq-node + flags: -cddl + +package cardano-diffusion + flags: +asserts -cddl diff --git a/scripts/ci/cabal.project.local.Windows b/scripts/ci/cabal.project.local.Windows index af847f4bb59..82912a6529a 100644 --- a/scripts/ci/cabal.project.local.Windows +++ b/scripts/ci/cabal.project.local.Windows @@ -1,32 +1,4 @@ -max-backjumps: 5000 -reorder-goals: True -tests: True -benchmarks: True - --- IPv6 and nothunks tests are DISABLED on Windows - -program-options - ghc-options: -fno-ignore-asserts -Werror - -package strict-checked-vars - flags: -checktvarinvariants -checkmvarinvariants - -package ntp-client - flags: +demo - -package network-mux - flags: -ipv6 - -package ouroboros-network - flags: +asserts -ipv6 - --- --- cddl is disabled on Windows due to missing build tool support in cross --- compilation --- +import ./scripts/cabal.project.local.Nix.Windows package dmq-node - flags: -cddl - -package cardano-diffusion - flags: +asserts -cddl + flags: -standardcrypto-tests