diff --git a/.stack-to-nix.cache b/.stack-to-nix.cache index 798ae7cd484..ebe4448c0af 100644 --- a/.stack-to-nix.cache +++ b/.stack-to-nix.cache @@ -86,3 +86,10 @@ https://github.com/input-output-hk/cardano-ledger 684195650722e4d337e90562fddcc5 https://github.com/input-output-hk/cardano-ledger 684195650722e4d337e90562fddcc5c2b0d17d34 test 17qmjcg2l1a31vmp6xs37prlqzq57rz9mly3s9xn5nbygzm2dgny cardano-ledger-test cardano-ledger-test.nix https://github.com/input-output-hk/cardano-prelude a136c4242b9c9f6124b811329bc8ccdfd86c514e test 0blwf2s4z7zfra4r9mha0g4irdz1migqspa2dn1ysg9jf2cn1bwj cardano-prelude-test cardano-prelude-test.nix https://github.com/input-output-hk/cardano-shell 5db8e79d319a86d48bea4cb70f1e904acae46de4 . 09s49qdispq2vld3ncnhwvqw5vzalra469q1x8w8kvdnc9b36ay1 cardano-shell cardano-shell.nix +https://github.com/input-output-hk/iohk-monitoring-framework f1c4ceef7d7ea6fb4425484c2b19b84048a3549d iohk-monitoring 0vyy18cbi2axcv6qck1mljiwk8vqc5p33ay05fpp8db26ykgw1nx iohk-monitoring iohk-monitoring.nix +https://github.com/input-output-hk/iohk-monitoring-framework f1c4ceef7d7ea6fb4425484c2b19b84048a3549d contra-tracer 0vyy18cbi2axcv6qck1mljiwk8vqc5p33ay05fpp8db26ykgw1nx contra-tracer contra-tracer.nix +https://github.com/input-output-hk/cardano-ledger 761feffb241c2db934c599dc330131ddee034322 . 0lgbmm1caikrds0wdqjl22wzr85d2hcvd0ppll3vbnfnk9dh6k6b cardano-ledger cardano-ledger.nix +https://github.com/input-output-hk/cardano-ledger 761feffb241c2db934c599dc330131ddee034322 crypto 0lgbmm1caikrds0wdqjl22wzr85d2hcvd0ppll3vbnfnk9dh6k6b cardano-crypto-wrapper cardano-crypto-wrapper.nix +https://github.com/input-output-hk/cardano-ledger 761feffb241c2db934c599dc330131ddee034322 crypto/test 0lgbmm1caikrds0wdqjl22wzr85d2hcvd0ppll3vbnfnk9dh6k6b cardano-crypto-test cardano-crypto-test.nix +https://github.com/input-output-hk/cardano-ledger 761feffb241c2db934c599dc330131ddee034322 test 0lgbmm1caikrds0wdqjl22wzr85d2hcvd0ppll3vbnfnk9dh6k6b cardano-ledger-test cardano-ledger-test.nix +https://github.com/input-output-hk/cardano-shell 4e9651df29752d1205719028e288ce9e0478a373 . 0avipzd1i18vn4sznsaisnrybg1n0pf00vzxhygx9idb91ws6bl0 cardano-shell cardano-shell.nix diff --git a/cabal.project b/cabal.project index 0d546b3ff66..115edab1166 100644 --- a/cabal.project +++ b/cabal.project @@ -21,13 +21,13 @@ source-repository-package type: git location: https://github.com/input-output-hk/iohk-monitoring-framework subdir: iohk-monitoring - tag: cbe7ab32354f3838dc8c95c64109904c8f503347 + tag: f1c4ceef7d7ea6fb4425484c2b19b84048a3549d source-repository-package type: git location: https://github.com/input-output-hk/iohk-monitoring-framework subdir: contra-tracer - tag: cbe7ab32354f3838dc8c95c64109904c8f503347 + tag: f1c4ceef7d7ea6fb4425484c2b19b84048a3549d source-repository-package type: git @@ -44,25 +44,25 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 684195650722e4d337e90562fddcc5c2b0d17d34 + tag: 761feffb241c2db934c599dc330131ddee034322 subdir: . source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 684195650722e4d337e90562fddcc5c2b0d17d34 + tag: 761feffb241c2db934c599dc330131ddee034322 subdir: crypto source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 684195650722e4d337e90562fddcc5c2b0d17d34 + tag: 761feffb241c2db934c599dc330131ddee034322 subdir: test source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 684195650722e4d337e90562fddcc5c2b0d17d34 + tag: 761feffb241c2db934c599dc330131ddee034322 subdir: crypto/test source-repository-package @@ -85,7 +85,7 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-shell - tag: 5db8e79d319a86d48bea4cb70f1e904acae46de4 + tag: 4e9651df29752d1205719028e288ce9e0478a373 source-repository-package type: git diff --git a/nix/.stack.nix/cardano-crypto-test.nix b/nix/.stack.nix/cardano-crypto-test.nix index 10205b68ec6..941765faa0e 100644 --- a/nix/.stack.nix/cardano-crypto-test.nix +++ b/nix/.stack.nix/cardano-crypto-test.nix @@ -34,8 +34,8 @@ } // { src = (pkgs.lib).mkDefault (pkgs.fetchgit { url = "https://github.com/input-output-hk/cardano-ledger"; - rev = "684195650722e4d337e90562fddcc5c2b0d17d34"; - sha256 = "17qmjcg2l1a31vmp6xs37prlqzq57rz9mly3s9xn5nbygzm2dgny"; + rev = "761feffb241c2db934c599dc330131ddee034322"; + sha256 = "0lgbmm1caikrds0wdqjl22wzr85d2hcvd0ppll3vbnfnk9dh6k6b"; }); postUnpack = "sourceRoot+=/crypto/test; echo source root reset to \$sourceRoot"; } \ No newline at end of file diff --git a/nix/.stack.nix/cardano-crypto-wrapper.nix b/nix/.stack.nix/cardano-crypto-wrapper.nix index 5820adea371..0678549be6d 100644 --- a/nix/.stack.nix/cardano-crypto-wrapper.nix +++ b/nix/.stack.nix/cardano-crypto-wrapper.nix @@ -59,8 +59,8 @@ } // { src = (pkgs.lib).mkDefault (pkgs.fetchgit { url = "https://github.com/input-output-hk/cardano-ledger"; - rev = "684195650722e4d337e90562fddcc5c2b0d17d34"; - sha256 = "17qmjcg2l1a31vmp6xs37prlqzq57rz9mly3s9xn5nbygzm2dgny"; + rev = "761feffb241c2db934c599dc330131ddee034322"; + sha256 = "0lgbmm1caikrds0wdqjl22wzr85d2hcvd0ppll3vbnfnk9dh6k6b"; }); postUnpack = "sourceRoot+=/crypto; echo source root reset to \$sourceRoot"; } \ No newline at end of file diff --git a/nix/.stack.nix/cardano-ledger-test.nix b/nix/.stack.nix/cardano-ledger-test.nix index fbcef20ce67..6889fcfd9b0 100644 --- a/nix/.stack.nix/cardano-ledger-test.nix +++ b/nix/.stack.nix/cardano-ledger-test.nix @@ -35,6 +35,7 @@ (hsPkgs.formatting) (hsPkgs.hedgehog) (hsPkgs.optparse-applicative) + (hsPkgs.tasty) (hsPkgs.text) (hsPkgs.time) (hsPkgs.vector) @@ -44,8 +45,8 @@ } // { src = (pkgs.lib).mkDefault (pkgs.fetchgit { url = "https://github.com/input-output-hk/cardano-ledger"; - rev = "684195650722e4d337e90562fddcc5c2b0d17d34"; - sha256 = "17qmjcg2l1a31vmp6xs37prlqzq57rz9mly3s9xn5nbygzm2dgny"; + rev = "761feffb241c2db934c599dc330131ddee034322"; + sha256 = "0lgbmm1caikrds0wdqjl22wzr85d2hcvd0ppll3vbnfnk9dh6k6b"; }); postUnpack = "sourceRoot+=/test; echo source root reset to \$sourceRoot"; } \ No newline at end of file diff --git a/nix/.stack.nix/cardano-ledger.nix b/nix/.stack.nix/cardano-ledger.nix index ef58b10224e..bfad4b21782 100644 --- a/nix/.stack.nix/cardano-ledger.nix +++ b/nix/.stack.nix/cardano-ledger.nix @@ -76,6 +76,8 @@ (hsPkgs.resourcet) (hsPkgs.small-steps) (hsPkgs.streaming) + (hsPkgs.tasty) + (hsPkgs.tasty-hedgehog) (hsPkgs.text) (hsPkgs.time) (hsPkgs.vector) @@ -86,7 +88,7 @@ } // { src = (pkgs.lib).mkDefault (pkgs.fetchgit { url = "https://github.com/input-output-hk/cardano-ledger"; - rev = "684195650722e4d337e90562fddcc5c2b0d17d34"; - sha256 = "17qmjcg2l1a31vmp6xs37prlqzq57rz9mly3s9xn5nbygzm2dgny"; + rev = "761feffb241c2db934c599dc330131ddee034322"; + sha256 = "0lgbmm1caikrds0wdqjl22wzr85d2hcvd0ppll3vbnfnk9dh6k6b"; }); } \ No newline at end of file diff --git a/nix/.stack.nix/cardano-shell.nix b/nix/.stack.nix/cardano-shell.nix index d1ff1f7fdfe..e07c33c7d82 100644 --- a/nix/.stack.nix/cardano-shell.nix +++ b/nix/.stack.nix/cardano-shell.nix @@ -98,7 +98,7 @@ } // { src = (pkgs.lib).mkDefault (pkgs.fetchgit { url = "https://github.com/input-output-hk/cardano-shell"; - rev = "5db8e79d319a86d48bea4cb70f1e904acae46de4"; - sha256 = "09s49qdispq2vld3ncnhwvqw5vzalra469q1x8w8kvdnc9b36ay1"; + rev = "4e9651df29752d1205719028e288ce9e0478a373"; + sha256 = "0avipzd1i18vn4sznsaisnrybg1n0pf00vzxhygx9idb91ws6bl0"; }); } \ No newline at end of file diff --git a/nix/.stack.nix/contra-tracer.nix b/nix/.stack.nix/contra-tracer.nix index 9abc1ae7a87..6ee3b74b86f 100644 --- a/nix/.stack.nix/contra-tracer.nix +++ b/nix/.stack.nix/contra-tracer.nix @@ -24,8 +24,8 @@ } // { src = (pkgs.lib).mkDefault (pkgs.fetchgit { url = "https://github.com/input-output-hk/iohk-monitoring-framework"; - rev = "cbe7ab32354f3838dc8c95c64109904c8f503347"; - sha256 = "1yipq7ghjmk5h0cjdpqbq9s00iv6wpj7zqh5b2nk4a6pz93fm6rv"; + rev = "f1c4ceef7d7ea6fb4425484c2b19b84048a3549d"; + sha256 = "0vyy18cbi2axcv6qck1mljiwk8vqc5p33ay05fpp8db26ykgw1nx"; }); postUnpack = "sourceRoot+=/contra-tracer; echo source root reset to \$sourceRoot"; } \ No newline at end of file diff --git a/nix/.stack.nix/iohk-monitoring.nix b/nix/.stack.nix/iohk-monitoring.nix index 2dcb0eaff83..77a2e167937 100644 --- a/nix/.stack.nix/iohk-monitoring.nix +++ b/nix/.stack.nix/iohk-monitoring.nix @@ -134,8 +134,8 @@ } // { src = (pkgs.lib).mkDefault (pkgs.fetchgit { url = "https://github.com/input-output-hk/iohk-monitoring-framework"; - rev = "cbe7ab32354f3838dc8c95c64109904c8f503347"; - sha256 = "1yipq7ghjmk5h0cjdpqbq9s00iv6wpj7zqh5b2nk4a6pz93fm6rv"; + rev = "f1c4ceef7d7ea6fb4425484c2b19b84048a3549d"; + sha256 = "0vyy18cbi2axcv6qck1mljiwk8vqc5p33ay05fpp8db26ykgw1nx"; }); postUnpack = "sourceRoot+=/iohk-monitoring; echo source root reset to \$sourceRoot"; } \ No newline at end of file diff --git a/nix/.stack.nix/ouroboros-consensus.nix b/nix/.stack.nix/ouroboros-consensus.nix index ee6901b27ab..fab07fbb8ba 100644 --- a/nix/.stack.nix/ouroboros-consensus.nix +++ b/nix/.stack.nix/ouroboros-consensus.nix @@ -22,18 +22,26 @@ (hsPkgs.typed-protocols) (hsPkgs.io-sim-classes) (hsPkgs.contra-tracer) + (hsPkgs.cardano-ledger-test) (hsPkgs.base16-bytestring) + (hsPkgs.bimap) (hsPkgs.bytestring) + (hsPkgs.cardano-binary) + (hsPkgs.cardano-crypto-wrapper) + (hsPkgs.cardano-ledger) + (hsPkgs.cardano-prelude) (hsPkgs.cborg) (hsPkgs.containers) (hsPkgs.cryptonite) (hsPkgs.directory) (hsPkgs.filepath) (hsPkgs.fingertree) + (hsPkgs.formatting) (hsPkgs.memory) (hsPkgs.mmorph) (hsPkgs.mtl) (hsPkgs.pipes) + (hsPkgs.reflection) (hsPkgs.serialise) (hsPkgs.text) (hsPkgs.time) @@ -51,12 +59,18 @@ (hsPkgs.ouroboros-network) (hsPkgs.ouroboros-consensus) (hsPkgs.io-sim-classes) + (hsPkgs.cardano-crypto-wrapper) + (hsPkgs.cardano-ledger) + (hsPkgs.cardano-ledger-test) + (hsPkgs.cardano-prelude) (hsPkgs.aeson) (hsPkgs.async) (hsPkgs.bytestring) + (hsPkgs.cborg) (hsPkgs.containers) (hsPkgs.cryptonite) (hsPkgs.directory) + (hsPkgs.formatting) (hsPkgs.mtl) (hsPkgs.optparse-applicative) (hsPkgs.serialise) diff --git a/ouroboros-consensus/demo-playground/CLI.hs b/ouroboros-consensus/demo-playground/CLI.hs index 6bb87190bc0..2501cfa0a0b 100644 --- a/ouroboros-consensus/demo-playground/CLI.hs +++ b/ouroboros-consensus/demo-playground/CLI.hs @@ -1,5 +1,12 @@ +{-# LANGUAGE GADTs #-} + module CLI ( - CLI(..) + -- * Untyped/typed protocol boundary + Protocol(..) + , SomeProtocol(..) + , fromProtocol + -- * CLI + , CLI(..) , TopologyInfo(..) , Command(..) , parseCLI @@ -25,6 +32,49 @@ import Ouroboros.Consensus.Util import Mock.TxSubmission (command', parseMockTx) import Topology (TopologyInfo (..)) +import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy + +{------------------------------------------------------------------------------- + Untyped/typed protocol boundary +-------------------------------------------------------------------------------} + +data Protocol = + BFT + | Praos + | MockPBFT + | RealPBFT + + +data SomeProtocol where + SomeProtocol :: RunDemo blk hdr => DemoProtocol blk hdr -> SomeProtocol + +fromProtocol :: Protocol -> IO SomeProtocol +fromProtocol BFT = + case runDemo p of + Dict -> return $ SomeProtocol p + where + p = DemoBFT defaultSecurityParam +fromProtocol Praos = + case runDemo p of + Dict -> return $ SomeProtocol p + where + p = DemoPraos defaultDemoPraosParams +fromProtocol MockPBFT = + case runDemo p of + Dict -> return $ SomeProtocol p + where + p = DemoMockPBFT defaultDemoPBftParams +fromProtocol RealPBFT = + case runDemo p of + Dict -> return $ SomeProtocol p + where + p = DemoRealPBFT defaultDemoPBftParams genesisConfig + genesisConfig = Dummy.dummyConfig + +{------------------------------------------------------------------------------- + Command line arguments +-------------------------------------------------------------------------------} + data CLI = CLI { systemStart :: SystemStart , slotDuration :: SlotLength @@ -32,7 +82,7 @@ data CLI = CLI { } data Command = - SimpleNode TopologyInfo (Some DemoProtocol) + SimpleNode TopologyInfo Protocol | TxSubmitter TopologyInfo Mock.Tx parseCLI :: Parser CLI @@ -57,19 +107,23 @@ parseSlotDuration = option (mkSlotLength <$> auto) $ mconcat [ mkSlotLength :: Integer -> SlotLength mkSlotLength = slotLengthFromMillisec . (* 1000) -parseProtocol :: Parser (Some DemoProtocol) +parseProtocol :: Parser Protocol parseProtocol = asum [ - flag' (Some (DemoBFT defaultSecurityParam)) $ mconcat [ + flag' BFT $ mconcat [ long "bft" , help "Use the BFT consensus algorithm" ] - , flag' (Some (DemoPraos defaultDemoPraosParams)) $ mconcat [ + , flag' Praos $ mconcat [ long "praos" , help "Use the Praos consensus algorithm" ] - , flag' (Some (DemoPBFT defaultDemoPBftParams)) $ mconcat [ - long "pbft" - , help "Use the Permissive BFT consensus algorithm" + , flag' MockPBFT $ mconcat [ + long "mock-pbft" + , help "Use the Permissive BFT consensus algorithm using a mock ledger" + ] + , flag' RealPBFT $ mconcat [ + long "real-pbft" + , help "Use the Permissive BFT consensus algorithm using the real ledger" ] ] diff --git a/ouroboros-consensus/demo-playground/Mock/TxSubmission.hs b/ouroboros-consensus/demo-playground/Mock/TxSubmission.hs index 3bc00b0334f..b7595cc86c9 100644 --- a/ouroboros-consensus/demo-playground/Mock/TxSubmission.hs +++ b/ouroboros-consensus/demo-playground/Mock/TxSubmission.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -10,7 +12,7 @@ module Mock.TxSubmission ( , spawnMempoolListener ) where -import Codec.Serialise (hPutSerialise) +import Codec.Serialise (decode, hPutSerialise) import qualified Control.Concurrent.Async as Async import Control.Monad.Except import Control.Tracer @@ -22,6 +24,7 @@ import System.IO (IOMode (..)) import Ouroboros.Consensus.Crypto.Hash (ShortHash) import qualified Ouroboros.Consensus.Crypto.Hash as H +import Ouroboros.Consensus.Demo import qualified Ouroboros.Consensus.Ledger.Mock as Mock import Ouroboros.Consensus.Mempool import Ouroboros.Consensus.Node (NodeId (..), NodeKernel (..)) @@ -80,7 +83,6 @@ command' c descr p = Main logic -------------------------------------------------------------------------------} - handleTxSubmission :: TopologyInfo -> Mock.Tx -> IO () handleTxSubmission tinfo tx = do topoE <- readTopologyFile (topologyFile tinfo) @@ -97,21 +99,23 @@ submitTx n tx = do putStrLn $ "The Id for this transaction is: " <> condense (H.hash @ShortHash tx) -- | Auxiliary to 'spawnMempoolListener' -readIncomingTx :: Tracer IO String - -> NodeKernel IO NodeId (Mock.SimpleBlock p c) (Mock.SimpleHeader p c) +readIncomingTx :: RunDemo blk hdr + => Tracer IO String + -> NodeKernel IO NodeId blk hdr -> Decoder IO -> IO () readIncomingTx tracer kernel Decoder{..} = forever $ do - newTx :: Mock.Tx <- decodeNext - rejected <- addTxs (getMempool kernel) [newTx] + newTx :: Mock.Tx <- decodeNext decode + rejected <- addTxs (getMempool kernel) [demoMockTx (getNodeConfig kernel) newTx] traceWith tracer $ (if null rejected then "Accepted" else "Rejected") <> " transaction: " <> show newTx -- | Listen for transactions coming a named pipe and add them to the mempool -spawnMempoolListener :: Tracer IO String +spawnMempoolListener :: RunDemo blk hdr + => Tracer IO String -> NodeId - -> NodeKernel IO NodeId (Mock.SimpleBlock p c) (Mock.SimpleHeader p c) + -> NodeKernel IO NodeId blk hdr -> IO (Async.Async ()) spawnMempoolListener tracer myNodeId kernel = do Async.async $ do diff --git a/ouroboros-consensus/demo-playground/Run.hs b/ouroboros-consensus/demo-playground/Run.hs index 97d8ad103ed..49e3bae19ec 100644 --- a/ouroboros-consensus/demo-playground/Run.hs +++ b/ouroboros-consensus/demo-playground/Run.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,17 +10,20 @@ module Run ( runNode ) where -import Codec.Serialise (decode, encode) +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) import qualified Control.Concurrent.Async as Async import Control.Monad import Control.Tracer import Crypto.Random +import Data.Functor.Contravariant (contramap) import qualified Data.Map.Strict as M import Data.Maybe import Data.Semigroup ((<>)) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block +import qualified Ouroboros.Network.Block as Block import Ouroboros.Network.Chain (genesisPoint, pointHash) import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Network.Protocol.BlockFetch.Codec @@ -28,9 +32,7 @@ import Ouroboros.Network.Protocol.ChainSync.Codec import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.ChainSyncClient (ClockSkew (..)) import Ouroboros.Consensus.Demo -import qualified Ouroboros.Consensus.Ledger.Mock as Mock import Ouroboros.Consensus.Node -import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.STM @@ -53,16 +55,15 @@ runNode cli@CLI{..} = do case command of TxSubmitter topology tx -> handleTxSubmission topology tx - SimpleNode topology protocol -> - case protocol of - Some p -> case demoProtocolConstraints p of - Dict -> handleSimpleNode p cli topology + SimpleNode topology protocol -> do + SomeProtocol p <- fromProtocol protocol + handleSimpleNode p cli topology -- | Sets up a simple node, which will run the chain sync protocol and block -- fetch protocol, and, if core, will also look at the mempool when trying to -- create a new block. -handleSimpleNode :: forall p. DemoProtocolConstraints p - => DemoProtocol p -> CLI -> TopologyInfo -> IO () +handleSimpleNode :: forall blk hdr. RunDemo blk hdr + => DemoProtocol blk hdr -> CLI -> TopologyInfo -> IO () handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do putStrLn $ "System started at " <> show systemStart t@(NetworkTopology nodeSetups) <- @@ -77,40 +78,41 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do putStrLn $ "My producers are " <> show (producers nodeSetup) putStrLn $ "**************************************" - let ProtocolInfo{..} = protocolInfo - p - (NumCoreNodes (length nodeSetups)) - (CoreNodeId nid) + let pInfo@ProtocolInfo{..} = + protocolInfo p (NumCoreNodes (length nodeSetups)) (CoreNodeId nid) withThreadRegistry $ \registry -> do - let callbacks :: NodeCallbacks IO (Block p) + let callbacks :: NodeCallbacks IO blk callbacks = NodeCallbacks { produceDRG = drgNew , produceBlock = \proof _l slot prevPoint prevBlockNo txs -> do - let curNo :: BlockNo - curNo = succ prevBlockNo + let curNo :: BlockNo + curNo = succ prevBlockNo - prevHash :: ChainHash (Header p) - prevHash = castHash (pointHash prevPoint) + prevHash :: ChainHash hdr + prevHash = castHash (pointHash prevPoint) -- The transactions we get are consistent; the only reason not -- to include all of them would be maximum block size, which -- we ignore for now. - Mock.forgeBlock pInfoConfig - slot - curNo - prevHash - txs - proof + demoForgeBlock pInfoConfig + slot + curNo + prevHash + txs + proof } - chainDB <- ChainDB.openDB encode pInfoConfig pInfoInitLedger Mock.simpleHeader + chainDB :: ChainDB IO blk hdr <- ChainDB.openDB + pInfoConfig + pInfoInitLedger + demoGetHeader btime <- realBlockchainTime registry slotDuration systemStart let tracer = contramap ((show myNodeId <> " | ") <>) stdoutTracer nodeParams = NodeParams - { tracer + { tracer = tracer , threadRegistry = registry , maxClockSkew = ClockSkew 1 , cfg = pInfoConfig @@ -118,9 +120,10 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do , btime , chainDB , callbacks - , blockFetchSize = Mock.headerBlockSize . Mock.headerPreHeader - , blockMatchesHeader = Mock.blockMatchesHeader + , blockFetchSize = demoBlockFetchSize + , blockMatchesHeader = demoBlockMatchesHeader } + kernel <- nodeKernel nodeParams watchChain registry tracer chainDB @@ -128,8 +131,8 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do -- Spawn the thread which listens to the mempool. mempoolThread <- spawnMempoolListener tracer myNodeId kernel - forM_ (producers nodeSetup) (addUpstream' kernel) - forM_ (consumers nodeSetup) (addDownstream' kernel) + forM_ (producers nodeSetup) (addUpstream' pInfo kernel) + forM_ (consumers nodeSetup) (addDownstream' pInfo kernel) Async.wait mempoolThread where @@ -140,7 +143,7 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do watchChain :: ThreadRegistry IO -> Tracer IO String - -> ChainDB IO (Block p) (Header p) + -> ChainDB IO blk hdr -> IO () watchChain registry tracer chainDB = onEachChange registry fingerprint initFingerprint @@ -156,35 +159,60 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do -- We need to make sure that both nodes read from the same file -- We therefore use the convention to distinguish between -- upstream and downstream from the perspective of the "lower numbered" node - addUpstream' :: NodeKernel IO NodeId (Block p) (Header p) + addUpstream' :: ProtocolInfo blk + -> NodeKernel IO NodeId blk hdr -> NodeId -> IO () - addUpstream' kernel producerNodeId = + addUpstream' pInfo@ProtocolInfo{..} kernel producerNodeId = addUpstream kernel producerNodeId nodeCommsCS nodeCommsBF where direction = Upstream (producerNodeId :==>: myNodeId) nodeCommsCS = NodeComms { - ncCodec = codecChainSync encode decode encode decode + ncCodec = codecChainSync + (demoEncodeHeader pInfoConfig) + (demoDecodeHeader pInfoConfig) + (encodePoint' pInfo) + (decodePoint' pInfo) , ncWithChan = NamedPipe.withPipeChannel "chain-sync" direction } nodeCommsBF = NodeComms { - ncCodec = codecBlockFetch encode encode decode decode + ncCodec = codecBlockFetch + (demoEncodeBlock pInfoConfig) + demoEncodeHeaderHash + (demoDecodeBlock pInfoConfig) + demoDecodeHeaderHash , ncWithChan = NamedPipe.withPipeChannel "block-fetch" direction } - - addDownstream' :: NodeKernel IO NodeId (Block p) (Header p) + addDownstream' :: ProtocolInfo blk + -> NodeKernel IO NodeId blk hdr -> NodeId -> IO () - addDownstream' kernel consumerNodeId = + addDownstream' pInfo@ProtocolInfo{..} kernel consumerNodeId = addDownstream kernel nodeCommsCS nodeCommsBF where direction = Downstream (myNodeId :==>: consumerNodeId) nodeCommsCS = NodeComms { - ncCodec = codecChainSync encode decode encode decode + ncCodec = codecChainSync + (demoEncodeHeader pInfoConfig) + (demoDecodeHeader pInfoConfig) + (encodePoint' pInfo) + (decodePoint' pInfo) , ncWithChan = NamedPipe.withPipeChannel "chain-sync" direction } nodeCommsBF = NodeComms { - ncCodec = codecBlockFetch encode encode decode decode + ncCodec = codecBlockFetch + (demoEncodeBlock pInfoConfig) + demoEncodeHeaderHash + (demoDecodeBlock pInfoConfig) + demoDecodeHeaderHash , ncWithChan = NamedPipe.withPipeChannel "block-fetch" direction } + + encodePoint' :: ProtocolInfo blk -> Point hdr -> Encoding + encodePoint' ProtocolInfo{..} = + Block.encodePoint $ Block.encodeChainHash demoEncodeHeaderHash + + decodePoint' :: forall s. ProtocolInfo blk -> Decoder s (Point hdr) + decodePoint' ProtocolInfo{..} = + Block.decodePoint $ Block.decodeChainHash demoDecodeHeaderHash diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index a7bf00e27b6..ef8ea8ab512 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -25,11 +25,11 @@ library exposed-modules: Ouroboros.Consensus.BlockchainTime - Ouroboros.Consensus.BlockFetchClient Ouroboros.Consensus.BlockFetchServer Ouroboros.Consensus.ChainSyncClient Ouroboros.Consensus.ChainSyncServer Ouroboros.Consensus.Crypto.DSIGN + Ouroboros.Consensus.Crypto.DSIGN.Cardano Ouroboros.Consensus.Crypto.DSIGN.Class Ouroboros.Consensus.Crypto.DSIGN.Ed448 Ouroboros.Consensus.Crypto.DSIGN.Mock @@ -49,6 +49,8 @@ library Ouroboros.Consensus.Crypto.VRF.Simple Ouroboros.Consensus.Demo Ouroboros.Consensus.Ledger.Abstract + Ouroboros.Consensus.Ledger.Byron + Ouroboros.Consensus.Ledger.Byron.Demo Ouroboros.Consensus.Ledger.Mock Ouroboros.Consensus.Mempool Ouroboros.Consensus.Mempool.API @@ -73,6 +75,7 @@ library Ouroboros.Consensus.Util.Random Ouroboros.Consensus.Util.Serialise Ouroboros.Consensus.Util.Singletons + Ouroboros.Consensus.Util.SlotBounded Ouroboros.Consensus.Util.STM Ouroboros.Consensus.Util.ThreadRegistry @@ -162,18 +165,31 @@ library io-sim-classes, contra-tracer, + -- TODO: Ideally we'd refactor this so that this + -- only needs to live in the demo-playground + cardano-ledger-test, + base16-bytestring >=0.1 && <0.2, + bimap >=0.3 && <0.4, bytestring >=0.10 && <0.11, + cardano-binary, + cardano-crypto-wrapper, + cardano-ledger, + cardano-prelude, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.7, cryptonite >=0.25 && <0.26, directory >=1.3 && <1.4, filepath >=1.4 && <1.5, fingertree >=0.1.4.2 && <0.2, + formatting >=6.3 && <6.4, memory >=0.14 && <0.15, mmorph >=1.1 && <1.2, mtl >=2.2 && <2.3, pipes >=4.3 && <4.4, + -- This is used only to address legacy issues, and its + -- usage should be discouraged in general + reflection, serialise >=0.2 && <0.3, text >=1.2 && <1.3, time, @@ -204,13 +220,19 @@ executable demo-playground ouroboros-network, ouroboros-consensus, io-sim-classes, + cardano-crypto-wrapper, + cardano-ledger, + cardano-ledger-test, + cardano-prelude, aeson, async, bytestring, + cborg, containers, cryptonite, directory, + formatting, mtl, optparse-applicative, serialise, diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockFetchClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockFetchClient.hs deleted file mode 100644 index a86d0052442..00000000000 --- a/ouroboros-consensus/src/Ouroboros/Consensus/BlockFetchClient.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Ouroboros.Consensus.BlockFetchClient - ( BlockFetchClient - , blockFetchClient - ) where - -import Network.TypedProtocol.Pipelined (PeerPipelined) -import Ouroboros.Network.Codec - -import Ouroboros.Network.BlockFetch.Client - (blockFetchClient, FetchClientContext) -import Ouroboros.Network.Protocol.BlockFetch.Type - (BlockFetch (BFIdle)) - --- | The block fetch layer doesn't provide a readable type for the client yet, --- so define it ourselves for now. -type BlockFetchClient hdr blk m a = - FetchClientContext hdr blk m -> - PeerPipelined (BlockFetch hdr blk) AsClient BFIdle m a - diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs index 9d21072c3a5..53068a73e6e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wredundant-constraints #-} module Ouroboros.Consensus.ChainSyncClient ( @@ -20,7 +21,6 @@ import Control.Monad.Except import Control.Tracer import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) import Data.Void (Void) import Data.Word (Word64) @@ -31,7 +31,7 @@ import Control.Monad.Class.MonadThrow import Ouroboros.Network.AnchoredFragment (AnchoredFragment (..)) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.Chain (genesisBlockNo, genesisPoint) +import Ouroboros.Network.Chain (genesisPoint, genesisSlotNo) import Ouroboros.Network.Protocol.ChainSync.Client import Ouroboros.Consensus.BlockchainTime @@ -40,6 +40,7 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () +import Ouroboros.Consensus.Util.SlotBounded as SB -- | Clock skew: the number of slots the chain of an upstream node may be @@ -53,15 +54,15 @@ newtype ClockSkew = ClockSkew { unClockSkew :: Word64 } type Consensus (client :: * -> * -> (* -> *) -> * -> *) hdr m = client hdr (Point hdr) m Void -data ChainSyncClientException blk hdr = +data ChainSyncClientException hdr = -- | The header we received was for a slot too far in the future. -- -- I.e., the slot of the received header was > current slot (according -- to the wall time) + the max clock skew. -- - -- The first 'SlotNo' argument is the slot of the received header, the - -- second 'SlotNo' argument is the current slot. - TooFarInTheFuture SlotNo SlotNo + -- The first 'Point' argument is the point of the received header, the + -- second 'SlotId' argument is the current slot (by wall clock). + HeaderExceedsClockSkew (Point hdr) SlotNo -- | The server we're connecting to forked more than @k@ blocks ago. -- @@ -69,8 +70,8 @@ data ChainSyncClientException blk hdr = -- too far in the past, the second 'Point' is the head of the server. | ForkTooDeep (Point hdr) (Point hdr) - -- | The ledger threw an error. - | LedgerError (LedgerError blk) + -- | The chain validation threw an error. + | ChainError (ValidationErr (BlockProtocol hdr)) -- | The upstream node rolled back more than @k@ blocks. -- @@ -86,17 +87,21 @@ data ChainSyncClientException blk hdr = | InvalidIntersection (Point hdr) -deriving instance (StandardHash hdr, Show (LedgerError blk)) - => Show (ChainSyncClientException blk hdr) +deriving instance ( StandardHash hdr + , OuroborosTag (BlockProtocol hdr) + ) + => Show (ChainSyncClientException hdr) -instance (Typeable hdr, Typeable blk, StandardHash hdr, Show (LedgerError blk)) - => Exception (ChainSyncClientException blk hdr) +instance ( Typeable hdr, StandardHash hdr + , OuroborosTag (BlockProtocol hdr) + ) + => Exception (ChainSyncClientException hdr) -- | The state of the candidate chain synched with an upstream node. -data CandidateState blk hdr = CandidateState - { candidateChain :: !(AnchoredFragment hdr) - , candidateHeaderState :: !(HeaderState blk) - -- ^ 'HeaderState' corresponding to the tip (most recent block) of the +data CandidateState hdr = CandidateState + { candidateChain :: !(AnchoredFragment hdr) + , candidateChainState :: !(ChainState (BlockProtocol hdr)) + -- ^ 'ChainState' corresponding to the tip (most recent block) of the -- 'candidateChain'. } @@ -111,10 +116,12 @@ chainSyncClient ( MonadSTM m , MonadThrow (STM m) , ProtocolLedgerView blk + , SupportedBlock (BlockProtocol hdr) hdr , HasHeader hdr - , BlockProtocol hdr ~ BlockProtocol blk , Ord up , Condense hdr, Condense (ChainHash hdr) + , BlockProtocol blk ~ BlockProtocol hdr + , HeaderHash blk ~ HeaderHash hdr ) => Tracer m String -> NodeConfig (BlockProtocol hdr) @@ -122,7 +129,7 @@ chainSyncClient -> ClockSkew -- ^ Maximum clock skew -> STM m (AnchoredFragment hdr) -- ^ Get the current chain -> STM m (ExtLedgerState blk) -- ^ Get the current ledger state - -> TVar m (Map up (TVar m (CandidateState blk hdr))) + -> TVar m (Map up (TVar m (CandidateState hdr))) -- ^ The candidate chains, we need the whole map because we -- (de)register nodes (@up@). -> up -> Consensus ChainSyncClient hdr m @@ -141,9 +148,9 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain -- selection. -- -- We also validate the headers of a candidate chain by advancing the - -- 'HeaderState' with the headers, which returns an error when validation + -- 'ChainState' with the headers, which returns an error when validation -- failed. Thus, in addition to the chain fragment of each candidate, we - -- also store a 'HeaderState' corresponding to the head of the candidate + -- also store a 'ChainState' corresponding to the head of the candidate -- chain. -- -- We must keep the candidate chain synchronised with the corresponding @@ -151,10 +158,25 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain -- backwards, and they will inform us about this. When we get these -- messages, we will replicate these actions on our candidate chain. -- - -- TODO #465 Simplification for now: we don't monitor our current chain in - -- order to reject candidates that are no longer eligible (fork off more - -- than @k@ blocks in the past) or to find a better intersection point. - -- TODO #472 is this alright for the 'HeaderState', won't it get stale? + -- INVARIANT: + -- + -- > our tip + -- > v + -- > /--* .... * + -- > | + -- > --* + -- > | + -- > \--* .... * + -- > fragment tip + -- + -- The distance from our tip to the intersection between our chain and the + -- fragment maintained for the upstream node cannot exceed @k@ blocks. When + -- this invariant cannot be maintained, the upstream node is on a fork that + -- is too distant and we should disconnect. + -- + -- TODO #579 Simplification for now: we don't maintain the above invariant + -- yet. Additionally, we don't monitor our current chain in order to find + -- a better intersection point either. -- -- TODO #465 Simplification for now: we don't trim candidate chains, so -- they might grow indefinitely. @@ -178,12 +200,12 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain initialise = do (curChain, varCandidate) <- atomically $ do curChain <- getCurrentChain - curLedger <- ledgerState <$> getCurrentLedger + curChainState <- ouroborosChainState <$> getCurrentLedger -- We use our current chain, which contains the last @k@ headers, as -- the initial chain for the candidate. varCandidate <- newTVar CandidateState { candidateChain = curChain - , candidateHeaderState = getHeaderState curLedger 0 + , candidateChainState = curChainState } modifyTVar' varCandidates $ Map.insert up varCandidate return (curChain, varCandidate) @@ -206,34 +228,46 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain ChainSyncClient . intersectUnchanged varCandidate } - -- One of the points we sent intersected our chain - intersectImproved :: TVar m (CandidateState blk hdr) + -- One of the points we sent intersected our chain. This intersection + -- point will become the new tip of the candidate chain. + intersectImproved :: TVar m (CandidateState hdr) -> Point hdr -> Point hdr -> m (Consensus ClientStIdle hdr m) intersectImproved varCandidate intersection _theirHead = atomically $ do - -- TODO #472 - curLedger <- ledgerState <$> getCurrentLedger - CandidateState { candidateChain } <- readTVar varCandidate + CandidateState { candidateChain, candidateChainState } <- readTVar varCandidate -- Roll back the candidate to the @intersection@. - candidateChain' <- case AF.rollback intersection candidateChain of - Just c -> return c - -- The @intersection@ is not on the candidate chain, even though we - -- sent only points from the candidate chain to find an intersection - -- with. The node must have sent us an invalid intersection point. - Nothing -> disconnect $ InvalidIntersection intersection - - -- Get the HeaderState corresponding to the point/block/header we rolled - -- back to. - let candidateHeaderState' = - getHeaderStateFor curLedger candidateChain candidateChain' + -- + -- While the primitives in the ChainSync protocol are "roll back", "roll + -- forward (apply block)", etc. The /real/ primitive is "switch to + -- fork", which means that a roll back is always followed by applying at + -- least as many blocks that we rolled back. + -- + -- This is important for 'rewindChainState', which can only roll back up + -- to @k@ blocks, /once/, i.e., we cannot keep rolling back the same + -- chain state multiple times, because that would mean that we store the + -- chain state for the /whole chain/, all the way to genesis. + -- + -- So the rewind below is fine when we are switching to a fork (i.e. it + -- is followed by rolling forward again), but we need some guarantees + -- that the ChainSync protocol /does/ in fact give us a switch-to-fork + -- instead of a true rollback. + (candidateChain', candidateChainState') <- + case (,) <$> AF.rollback intersection candidateChain + <*> rewindChainState cfg candidateChainState (pointSlot intersection) + of + Just (c,d) -> return (c,d) + -- The @intersection@ is not on the candidate chain, even though we + -- sent only points from the candidate chain to find an intersection + -- with. The node must have sent us an invalid intersection point. + Nothing -> disconnect $ InvalidIntersection intersection -- TODO make sure the header state is fully evaluated, otherwise we'd -- hang on to the entire ledger state. This applies to everywhere we -- update the header state. writeTVar varCandidate CandidateState - { candidateChain = candidateChain' - , candidateHeaderState = candidateHeaderState' + { candidateChain = candidateChain' + , candidateChainState = candidateChainState' } return $ requestNext varCandidate @@ -245,12 +279,11 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain -- we later optimise this client to also find intersections after -- start-up, this code will have to be adapted, as it assumes it is only -- called at start-up. - intersectUnchanged :: TVar m (CandidateState blk hdr) + intersectUnchanged :: TVar m (CandidateState hdr) -> Point hdr -> m (Consensus ClientStIdle hdr m) intersectUnchanged varCandidate theirHead = atomically $ do - -- TODO #472 - curLedger <- ledgerState <$> getCurrentLedger + curChainState <- ouroborosChainState <$> getCurrentLedger CandidateState { candidateChain } <- readTVar varCandidate -- If the genesis point is within the bounds of the candidate fragment @@ -262,123 +295,171 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain unless (AF.withinFragmentBounds genesisPoint candidateChain) $ disconnect $ ForkTooDeep genesisPoint theirHead - -- Get the 'HeaderState' at genesis (0). + -- Get the 'ChainState' at genesis. let candidateChain' = Empty genesisPoint - candidateHeaderState' = - getHeaderStateFor curLedger candidateChain candidateChain' + candidateChainState' <- case rewindChainState cfg curChainState genesisSlotNo of + Nothing -> disconnect $ ForkTooDeep genesisPoint theirHead + Just c -> pure c writeTVar varCandidate CandidateState { candidateChain = candidateChain' - , candidateHeaderState = candidateHeaderState' + , candidateChainState = candidateChainState' } return $ requestNext varCandidate - requestNext :: TVar m (CandidateState blk hdr) + requestNext :: TVar m (CandidateState hdr) -> Consensus ClientStIdle hdr m requestNext varCandidate = SendMsgRequestNext (handleNext varCandidate) (return (handleNext varCandidate)) -- when we have to wait - handleNext :: TVar m (CandidateState blk hdr) + handleNext :: TVar m (CandidateState hdr) -> Consensus ClientStNext hdr m handleNext varCandidate = ClientStNext { recvMsgRollForward = \hdr theirHead -> ChainSyncClient $ do - res <- rollForward varCandidate hdr theirHead traceWith tracer $ "Downloaded header: " <> condense hdr - return res + rollForward varCandidate hdr theirHead , recvMsgRollBackward = \intersection theirHead -> ChainSyncClient $ do - res <- rollBackward varCandidate intersection theirHead - traceWith tracer $ "Rolled back to: " <> condense intersection - return res + traceWith tracer $ "Rolling back to: " <> condense intersection + rollBackward varCandidate intersection theirHead } - rollForward :: TVar m (CandidateState blk hdr) + rollForward :: TVar m (CandidateState hdr) -> hdr -> Point hdr -> m (Consensus ClientStIdle hdr m) - rollForward varCandidate hdr theirHead = atomically $ do - currentSlot <- getCurrentSlot btime - let theirSlot = AF.pointSlot theirHead - - when (unSlotNo theirSlot > unSlotNo currentSlot + maxSkew) $ - disconnect $ TooFarInTheFuture theirSlot currentSlot - - -- TODO #472 + rollForward varCandidate hdr _theirHead = atomically $ do + -- To validate the block, we need the consensus chain state (updated using + -- headers only, and kept as part of the candidate state) and the + -- (anachronistic) ledger view. We read the latter as the first thing in + -- the transaction, because we might have to retry the transaction if the + -- ledger state is too far behind the upstream peer (see below). curLedger <- ledgerState <$> getCurrentLedger + let hdrPoint, ourTip :: Point hdr + hdrPoint = blockPoint hdr + ourTip = castPoint $ ledgerTipPoint curLedger + + -- NOTE: Low density chains + -- + -- The ledger gives us an "anachronistic ledger view", which allows us to + -- validate headers within a certain range of slots, provided that we + -- maintain the invariant that the intersecton between our tip and the tip + -- of the peer fragment is within @k@ blocks from our tip (see detailed + -- description at 'anachronisticProtocolLedgerView'). This range is in + -- terms of /slots/, not blocks: this is important, because certain + -- transitions on the ledger happen at slot boundaries (for instance, + -- update proposals). + -- + -- Under normal circumstances this is fine, but it can be problematic in + -- the case of low density chains. For example, we might get the header + -- for a block which is only two /blocks/ away from our current tip, but + -- many slots (because for whatever reason simply no blocks were produced + -- at all in that period). + -- + -- We can mitigate this to /some/ degree by introducing one special case: + -- if the header that we receive fits /directly/ onto our current chain, + -- we can validate it even if it is outside the anachronistic ledger view + -- window (based on its slot number). This is a useful special case + -- because it means that we can catch up with a node that has an extension + -- of our chain, even if there are many empty slots in between. + -- + -- It is important to realize however that this special case does not help + -- with forks. Suppose we have + -- + -- > our tip + -- > v + -- > --*--* + -- > | + -- > \--*--*--*--*-- (chain we might be able to switch to) + -- > A + -- + -- If the slot number for the block marked @A@ is way in the future, + -- we will not be able to verify it and so we will not be able to switch + -- to this fork. + ledgerView <- + if blockPrevHash hdr == pointHash ourTip then + -- Special case mentioned above + return $ protocolLedgerView cfg curLedger + else + -- The invariant guarantees us that the intersection of their tip + -- and our tip is within k blocks from our tip. This means that the + -- anachronistic ledger view must be available, unless they are + -- too far /ahead/ of us. In this case we must simply wait + + -- TODO: Chain sync Client: Reuse anachronistic ledger view? #581 + case anachronisticProtocolLedgerView cfg curLedger (pointSlot hdrPoint) of + Nothing -> retry + Just view -> case view `SB.at` pointSlot hdrPoint of + Nothing -> error "anachronisticProtocolLedgerView invariant violated" + Just lv -> return lv + + -- Check for clock skew + wallclock <- getCurrentSlot btime + when (unSlotNo (pointSlot hdrPoint) > unSlotNo wallclock + maxSkew) $ + disconnect $ HeaderExceedsClockSkew hdrPoint wallclock + + -- Validate header CandidateState {..} <- readTVar varCandidate + candidateChainState' <- + case runExcept $ applyChainState cfg ledgerView hdr candidateChainState of + Left vErr -> disconnect $ ChainError vErr + Right candidateChainState' -> return candidateChainState' - candidateHeaderState' <- - case runExcept $ advanceHeader curLedger hdr candidateHeaderState of - Left ledgerError -> disconnect $ LedgerError ledgerError - Right candidateHeaderState' -> return candidateHeaderState' writeTVar varCandidate CandidateState - { candidateChain = candidateChain :> hdr - , candidateHeaderState = candidateHeaderState' + { candidateChain = candidateChain :> hdr + , candidateChainState = candidateChainState' } return $ requestNext varCandidate - rollBackward :: TVar m (CandidateState blk hdr) + rollBackward :: TVar m (CandidateState hdr) -> Point hdr -> Point hdr -> m (Consensus ClientStIdle hdr m) rollBackward varCandidate intersection theirHead = atomically $ do CandidateState {..} <- readTVar varCandidate - candidateChain' <- case AF.rollback intersection candidateChain of - Just candidateChain' -> return candidateChain' - -- Remember that we use our current chain fragment as the starting - -- point for the candidate's chain. Our fragment contained @k@ - -- headers. At this point, the candidate fragment might have grown to - -- more than @k@ or rolled back to less than @k@ headers. - -- - -- But now, it rolled back to some point that is not on the fragment, - -- which means that it tried to roll back to some point before one of - -- the last @k@ headers we initially started from. We could never - -- switch to this fork anyway, so just disconnect. Furthermore, our - -- current chain might have advanced in the meantime, so the point we - -- would have to roll back to might have been much further back than - -- @k@ blocks (> @k@ + the number of blocks we have advanced since - -- starting syncing). - Nothing -> disconnect $ - InvalidRollBack intersection theirHead - - -- TODO #472 - curLedger <- ledgerState <$> getCurrentLedger - let candidateHeaderState' = - getHeaderStateFor curLedger candidateChain candidateChain' + (candidateChain', candidateChainState') <- + case (,) <$> AF.rollback intersection candidateChain + <*> rewindChainState cfg candidateChainState (pointSlot intersection) + of + Just (c,d) -> return (c,d) + -- Remember that we use our current chain fragment as the starting + -- point for the candidate's chain. Our fragment contained @k@ + -- headers. At this point, the candidate fragment might have grown to + -- more than @k@ or rolled back to less than @k@ headers. + -- + -- But now, it rolled back to some point that is not on the fragment, + -- which means that it tried to roll back to some point before one of + -- the last @k@ headers we initially started from. We could never + -- switch to this fork anyway, so just disconnect. Furthermore, our + -- current chain might have advanced in the meantime, so the point we + -- would have to roll back to might have been much further back than + -- @k@ blocks (> @k@ + the number of blocks we have advanced since + -- starting syncing). + -- + -- INVARIANT: a candidate fragment contains @>=k@ headers (unless + -- near genesis, in which case we mean the total number of blocks in + -- the fragment) minus @r@ headers where @r <= k@. This ghost + -- variable @r@ indicates the number of headers we temporarily + -- rolled back. Such a rollback must always be followed by rolling + -- forward @s@ new headers where @s >= r@. + -- + -- Thus, @k - r + s >= k@. + Nothing -> disconnect $ + InvalidRollBack intersection theirHead + writeTVar varCandidate CandidateState - { candidateChain = candidateChain' - , candidateHeaderState = candidateHeaderState' + { candidateChain = candidateChain' + , candidateChainState = candidateChainState' } return $ requestNext varCandidate -- | Disconnect from the upstream node by throwing the given exception and -- removing its candidate from the map of candidates. - disconnect :: ChainSyncClientException blk hdr -> STM m a + disconnect :: ChainSyncClientException hdr -> STM m a disconnect ex = do modifyTVar' varCandidates $ Map.delete up throwM ex - -- | Get the 'HeaderState' for the head of the given chain. - getHeaderStateFor - :: LedgerState blk - -> AnchoredFragment hdr - -- ^ The ledger state corresponds to the head of this chain - -> AnchoredFragment hdr - -- ^ We want the ledger state for the head of this chain - -> HeaderState blk - getHeaderStateFor ledgerState ledgerChain wantedChain = - getHeaderState ledgerState rollBack - where - ledgerHeadBlockNo = mostRecentBlockNo ledgerChain - wantedHeadBlockNo = mostRecentBlockNo wantedChain - rollBack = unBlockNo ledgerHeadBlockNo - unBlockNo wantedHeadBlockNo - - -- | Return the 'BlockNo' of the most recent header of the given chain, - -- the one at the tip. If the fragment is empty, it must be that we're - -- near genesis, so return 'genesisBlockNo' in that case. - mostRecentBlockNo :: AnchoredFragment hdr -> BlockNo - mostRecentBlockNo = fromMaybe genesisBlockNo . AF.headBlockNo - -- Recent offsets -- -- These offsets are used to find an intersection point between our chain diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN.hs index 59b9af5f71a..37abc85683e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN.hs @@ -1,12 +1,15 @@ -- | Digital signatures. module Ouroboros.Consensus.Crypto.DSIGN ( module Class + , module Cardano , module Ed448 , module Mock , module RSAPSS ) where import Ouroboros.Consensus.Crypto.DSIGN.Class as Class + +import Ouroboros.Consensus.Crypto.DSIGN.Cardano as Cardano import Ouroboros.Consensus.Crypto.DSIGN.Ed448 as Ed448 import Ouroboros.Consensus.Crypto.DSIGN.Mock as Mock import Ouroboros.Consensus.Crypto.DSIGN.RSAPSS as RSAPSS diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs new file mode 100644 index 00000000000..5048b1a2dd6 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Cardano digital signatures. +module Ouroboros.Consensus.Crypto.DSIGN.Cardano + ( CardanoDSIGN + , VerKeyDSIGN(..) + , SignKeyDSIGN(..) + , SigDSIGN(..) + , HasSignTag(..) + ) where + +import Cardano.Binary +import qualified Cardano.Chain.Block as CC.Block +import qualified Cardano.Chain.UTxO as CC.UTxO +import Cardano.Crypto (ProtocolMagicId, ProxyVerificationKey, + SignTag (..), Signature, SigningKey, VerificationKey, + keyGen, signEncoded, toVerification, verifySignature) +import Data.Coerce (coerce) +import Data.Function (on) +import Data.Proxy (Proxy (..)) +import Data.Reflection (Given (..)) +import GHC.Generics (Generic) + +import Ouroboros.Consensus.Crypto.DSIGN.Class +import Ouroboros.Consensus.Util.Condense + + +class HasSignTag a where + signTag :: proxy a -> SignTag + +signTagFor :: forall a. HasSignTag a => a -> SignTag +signTagFor _ = signTag (Proxy @a) + +instance HasSignTag CC.UTxO.TxSigData where + signTag = const SignTx + +instance HasSignTag CC.Block.ToSign where + signTag = const SignMainBlock + +instance HasSignTag (ProxyVerificationKey w) where + signTag = const SignProxyVK + +data CardanoDSIGN + +instance Given ProtocolMagicId => DSIGNAlgorithm CardanoDSIGN where + + newtype VerKeyDSIGN CardanoDSIGN = VerKeyCardanoDSIGN VerificationKey + deriving (Show, Eq, Generic) + + newtype SignKeyDSIGN CardanoDSIGN = SignKeyCardanoDSIGN SigningKey + deriving (Show, Eq, Generic) + + newtype SigDSIGN CardanoDSIGN = SigCardanoDSIGN (Signature Encoding) + deriving (Show, Eq, Generic) + + type Signable CardanoDSIGN = HasSignTag + + encodeVerKeyDSIGN (VerKeyCardanoDSIGN pk) = toCBOR pk + decodeVerKeyDSIGN = VerKeyCardanoDSIGN <$> fromCBOR + + encodeSignKeyDSIGN (SignKeyCardanoDSIGN pk) = toCBOR pk + decodeSignKeyDSIGN = SignKeyCardanoDSIGN <$> fromCBOR + + encodeSigDSIGN (SigCardanoDSIGN pk) = toCBOR pk + decodeSigDSIGN = SigCardanoDSIGN <$> fromCBOR + + genKeyDSIGN = SignKeyCardanoDSIGN . snd <$> keyGen + + deriveVerKeyDSIGN (SignKeyCardanoDSIGN sk) = VerKeyCardanoDSIGN $ toVerification sk + + signDSIGN toEnc a (SignKeyCardanoDSIGN sk) = do + return $ SigCardanoDSIGN $ signEncoded given (signTagFor a) sk (toEnc a) + + verifyDSIGN toEnc (VerKeyCardanoDSIGN vk) a (SigCardanoDSIGN sig) = + if verifySignature toEnc given (signTagFor a) vk a $ coerce sig + then Right () + else Left "Verification failed" + +instance Ord (VerKeyDSIGN CardanoDSIGN) where + compare = compare `on` show + +instance Ord (SignKeyDSIGN CardanoDSIGN) where + compare = compare `on` show + +instance Ord (SigDSIGN CardanoDSIGN) where + compare = compare `on` show + +instance Condense (SigDSIGN CardanoDSIGN) where + condense (SigCardanoDSIGN s) = show s diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Class.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Class.hs index d34ac7e2291..c5871e46559 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Class.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Class.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -14,10 +16,14 @@ module Ouroboros.Consensus.Crypto.DSIGN.Class , decodeSignedDSIGN ) where -import Codec.Serialise.Encoding (Encoding) import Codec.CBOR.Decoding (Decoder) +import Codec.Serialise.Encoding (Encoding) import Crypto.Random (MonadRandom) +import GHC.Exts (Constraint) import GHC.Generics (Generic) +import GHC.Stack + +import Ouroboros.Consensus.Util (Empty) import Ouroboros.Consensus.Util.Condense class ( Show (VerKeyDSIGN v) @@ -34,17 +40,25 @@ class ( Show (VerKeyDSIGN v) data SignKeyDSIGN v :: * data SigDSIGN v :: * - encodeVerKeyDSIGN :: VerKeyDSIGN v -> Encoding - decodeVerKeyDSIGN :: Decoder s (VerKeyDSIGN v) + type Signable v :: * -> Constraint + type Signable c = Empty + + encodeVerKeyDSIGN :: VerKeyDSIGN v -> Encoding encodeSignKeyDSIGN :: SignKeyDSIGN v -> Encoding + encodeSigDSIGN :: SigDSIGN v -> Encoding + + decodeVerKeyDSIGN :: Decoder s (VerKeyDSIGN v) decodeSignKeyDSIGN :: Decoder s (SignKeyDSIGN v) - encodeSigDSIGN :: SigDSIGN v -> Encoding - decodeSigDSIGN :: Decoder s (SigDSIGN v) + decodeSigDSIGN :: Decoder s (SigDSIGN v) genKeyDSIGN :: MonadRandom m => m (SignKeyDSIGN v) deriveVerKeyDSIGN :: SignKeyDSIGN v -> VerKeyDSIGN v - signDSIGN :: MonadRandom m => (a -> Encoding) -> a -> SignKeyDSIGN v -> m (SigDSIGN v) - verifyDSIGN :: (a -> Encoding) -> VerKeyDSIGN v -> a -> SigDSIGN v -> Bool + signDSIGN :: (MonadRandom m, Signable v a) + => (a -> Encoding) + -> a -> SignKeyDSIGN v -> m (SigDSIGN v) + verifyDSIGN :: (Signable v a, HasCallStack) + => (a -> Encoding) + -> VerKeyDSIGN v -> a -> SigDSIGN v -> Either String () newtype SignedDSIGN v a = SignedDSIGN (SigDSIGN v) deriving (Generic) @@ -56,12 +70,14 @@ deriving instance DSIGNAlgorithm v => Ord (SignedDSIGN v a) instance Condense (SigDSIGN v) => Condense (SignedDSIGN v a) where condense (SignedDSIGN sig) = condense sig -signedDSIGN :: (DSIGNAlgorithm v, MonadRandom m) - => (a -> Encoding) -> a -> SignKeyDSIGN v -> m (SignedDSIGN v a) +signedDSIGN :: (DSIGNAlgorithm v, MonadRandom m, Signable v a) + => (a -> Encoding) + -> a -> SignKeyDSIGN v -> m (SignedDSIGN v a) signedDSIGN encoder a key = SignedDSIGN <$> signDSIGN encoder a key -verifySignedDSIGN :: DSIGNAlgorithm v - => (a -> Encoding) -> VerKeyDSIGN v -> a -> SignedDSIGN v a -> Bool +verifySignedDSIGN :: (DSIGNAlgorithm v, Signable v a, HasCallStack) + => (a -> Encoding) + -> VerKeyDSIGN v -> a -> SignedDSIGN v a -> Either String () verifySignedDSIGN encoder key a (SignedDSIGN s) = verifyDSIGN encoder key a s encodeSignedDSIGN :: DSIGNAlgorithm v => SignedDSIGN v a -> Encoding diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Ed448.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Ed448.hs index 26dd0ccb756..a63719070ec 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Ed448.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Ed448.hs @@ -49,7 +49,10 @@ instance DSIGNAlgorithm Ed448DSIGN where bs = toBS $ toEnc a return $ SigEd448DSIGN $ sign sk vk bs - verifyDSIGN toEnc (VerKeyEd448DSIGN vk) a (SigEd448DSIGN sig) = verify vk (toBS $ toEnc a) sig + verifyDSIGN toEnc (VerKeyEd448DSIGN vk) a (SigEd448DSIGN sig) = + if verify vk (toBS $ toEnc a) sig + then Right () + else Left "Verification failed" instance Ord (VerKeyDSIGN Ed448DSIGN) where compare = compare `on` show diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Mock.hs index e8886753a74..bd9cd9944dd 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Mock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} @@ -12,9 +13,10 @@ module Ouroboros.Consensus.Crypto.DSIGN.Mock , mockSign ) where -import Codec.Serialise (Serialise(..)) import Codec.CBOR.Encoding (Encoding) +import Codec.Serialise (Serialise (..)) import GHC.Generics (Generic) +import GHC.Stack import Ouroboros.Consensus.Crypto.DSIGN.Class import Ouroboros.Consensus.Crypto.Hash @@ -34,13 +36,13 @@ instance DSIGNAlgorithm MockDSIGN where data SigDSIGN MockDSIGN = SigMockDSIGN ByteString Int deriving (Show, Eq, Ord, Generic) - encodeVerKeyDSIGN = encode + encodeVerKeyDSIGN = encode encodeSignKeyDSIGN = encode - encodeSigDSIGN = encode + encodeSigDSIGN = encode - decodeVerKeyDSIGN = decode + decodeVerKeyDSIGN = decode decodeSignKeyDSIGN = decode - decodeSigDSIGN = decode + decodeSigDSIGN = decode genKeyDSIGN = SignKeyMockDSIGN <$> nonNegIntR @@ -48,7 +50,25 @@ instance DSIGNAlgorithm MockDSIGN where signDSIGN toEnc a sk = return $ mockSign toEnc a sk - verifyDSIGN toEnc (VerKeyMockDSIGN n) a s = s == mockSign toEnc a (SignKeyMockDSIGN n) + verifyDSIGN toEnc (VerKeyMockDSIGN n) a s = + if s == mockSign toEnc a (SignKeyMockDSIGN n) + then Right () + else Left $ show $ MockVerificationFailure { + vErrVerKey = VerKeyMockDSIGN n + , vErrSignature = s + , vErrCallStack = prettyCallStack callStack + } + +-- | Debugging: provide information about the verification failure +-- +-- We don't include the actual value here as that would require propagating a +-- 'Show' constraint. +data VerificationFailure = MockVerificationFailure { + vErrVerKey :: VerKeyDSIGN MockDSIGN + , vErrSignature :: SigDSIGN MockDSIGN + , vErrCallStack :: String + } + deriving (Show) mockSign :: (a -> Encoding) -> a -> SignKeyDSIGN MockDSIGN -> SigDSIGN MockDSIGN mockSign toEnc a (SignKeyMockDSIGN n) = SigMockDSIGN (getHash $ hashWithSerialiser @ShortHash toEnc a) n diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/RSAPSS.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/RSAPSS.hs index 1e99710f477..c963574f94d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/RSAPSS.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/RSAPSS.hs @@ -63,7 +63,9 @@ instance DSIGNAlgorithm RSAPSSDSIGN where Right sig -> return $ SigRSAPSSDSIGN sig verifyDSIGN toEnc (VerKeyRSAPSSDSIGN vk) a (SigRSAPSSDSIGN sig) = - verify defaultPSSParamsSHA1 vk (toBS $ toEnc a) sig + if verify defaultPSSParamsSHA1 vk (toBS $ toEnc a) sig + then Right () + else Left "Verification failed" instance Ord (VerKeyDSIGN RSAPSSDSIGN) where compare = compare `on` show diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Class.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Class.hs index bc0e56de849..2eb5fa5bc23 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Class.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Class.hs @@ -13,11 +13,13 @@ module Ouroboros.Consensus.Crypto.KES.Class , verifySignedKES ) where -import Codec.Serialise.Encoding (Encoding) import Codec.CBOR.Decoding (Decoder) +import Codec.Serialise.Encoding (Encoding) +import GHC.Exts (Constraint) import GHC.Generics (Generic) import Numeric.Natural (Natural) +import Ouroboros.Consensus.Util (Empty) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Random @@ -35,6 +37,9 @@ class ( Show (VerKeyKES v) data SignKeyKES v :: * data SigKES v :: * + type Signable v :: * -> Constraint + type Signable c = Empty + encodeVerKeyKES :: VerKeyKES v -> Encoding decodeVerKeyKES :: Decoder s (VerKeyKES v) encodeSignKeyKES :: SignKeyKES v -> Encoding @@ -44,13 +49,15 @@ class ( Show (VerKeyKES v) genKeyKES :: MonadRandom m => Natural -> m (SignKeyKES v) deriveVerKeyKES :: SignKeyKES v -> VerKeyKES v - signKES :: (MonadRandom m) + signKES :: (MonadRandom m, Signable v a) => (a -> Encoding) -> Natural -> a -> SignKeyKES v -> m (Maybe (SigKES v, SignKeyKES v)) - verifyKES :: (a -> Encoding) -> VerKeyKES v -> Natural -> a -> SigKES v -> Bool + verifyKES :: Signable v a + => (a -> Encoding) + -> VerKeyKES v -> Natural -> a -> SigKES v -> Either String () newtype SignedKES v a = SignedKES {getSig :: SigKES v} deriving (Generic) @@ -62,7 +69,7 @@ deriving instance KESAlgorithm v => Ord (SignedKES v a) instance Condense (SigKES v) => Condense (SignedKES v a) where condense (SignedKES sig) = condense sig -signedKES :: (KESAlgorithm v, MonadRandom m) +signedKES :: (KESAlgorithm v, MonadRandom m, Signable v a) => (a -> Encoding) -> Natural -> a -> SignKeyKES v -> m (Maybe (SignedKES v a, SignKeyKES v)) signedKES toEnc time a key = do m <- signKES toEnc time a key @@ -70,6 +77,7 @@ signedKES toEnc time a key = do Nothing -> Nothing Just (sig, key') -> Just (SignedKES sig, key') -verifySignedKES :: (KESAlgorithm v) - => (a -> Encoding) -> VerKeyKES v -> Natural -> a -> SignedKES v a -> Bool +verifySignedKES :: (KESAlgorithm v, Signable v a) + => (a -> Encoding) + -> VerKeyKES v -> Natural -> a -> SignedKES v a -> Either String () verifySignedKES toEnc vk j a (SignedKES sig) = verifyKES toEnc vk j a sig diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Mock.hs index 74fcb4dd602..7e4d2766f3d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Mock.hs @@ -57,9 +57,11 @@ instance KESAlgorithm MockKES where | otherwise = return Nothing verifyKES toEnc vk j a (SigMockKES h (SignKeyMockKES (vk', j', _))) = - j == j' && - vk == vk' && - fromHash (hashWithSerialiser @H toEnc a) == h + if j == j' + && vk == vk' + && fromHash (hashWithSerialiser @H toEnc a) == h + then Right () + else Left "KES verification failed" instance Serialise (SigKES MockKES) where diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Simple.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Simple.hs index bc27945f46d..e87d4273781 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Simple.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Simple.hs @@ -5,15 +5,16 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Mock key evolving signatures. module Ouroboros.Consensus.Crypto.KES.Simple ( SimpleKES ) where -import Codec.Serialise (Serialise(..)) -import qualified Codec.Serialise.Encoding as Enc +import Codec.Serialise (Serialise (..)) import qualified Codec.Serialise.Decoding as Dec +import qualified Codec.Serialise.Encoding as Enc import Control.Monad (replicateM) import Data.Vector (Vector, fromList, (!?)) import qualified Data.Vector as Vec @@ -21,12 +22,13 @@ import GHC.Generics (Generic) import Numeric.Natural (Natural) import Ouroboros.Consensus.Crypto.DSIGN +import qualified Ouroboros.Consensus.Crypto.DSIGN as DSIGN import Ouroboros.Consensus.Crypto.KES.Class import Ouroboros.Consensus.Util.Condense data SimpleKES d -instance DSIGNAlgorithm d => KESAlgorithm (SimpleKES d) where +instance (DSIGNAlgorithm d) => KESAlgorithm (SimpleKES d) where newtype VerKeyKES (SimpleKES d) = VerKeySimpleKES (Vector (VerKeyDSIGN d)) deriving Generic @@ -38,6 +40,8 @@ instance DSIGNAlgorithm d => KESAlgorithm (SimpleKES d) where newtype SigKES (SimpleKES d) = SigSimpleKES (SigDSIGN d) deriving Generic + type Signable (SimpleKES d) = DSIGN.Signable d + encodeVerKeyKES = encode encodeSignKeyKES = encode encodeSigKES = encode @@ -61,7 +65,7 @@ instance DSIGNAlgorithm d => KESAlgorithm (SimpleKES d) where verifyKES toEnc (VerKeySimpleKES vks) j a (SigSimpleKES sig) = case vks !? fromIntegral j of - Nothing -> False + Nothing -> Left "KES verification failed: out of range" Just vk -> verifyDSIGN toEnc vk a sig deriving instance DSIGNAlgorithm d => Show (VerKeyKES (SimpleKES d)) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs index 94f04dab92f..f8b41c47ec2 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs @@ -1,27 +1,35 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} -- | Instantiations of the protocol stack used in tests and demos module Ouroboros.Consensus.Demo ( -- * Abstract over protocols DemoProtocol(..) , DemoBFT - , DemoPBFT , DemoPraos , DemoLeaderSchedule - , Block - , Header + , DemoMockPBFT + , DemoRealPBFT , NumCoreNodes(..) , ProtocolInfo(..) , protocolInfo - , DemoProtocolConstraints - , demoProtocolConstraints + , RunDemo(..) + , DemoBlock(..) + , DemoHeader(..) + , DemoHeaderHash(..) + , runDemo -- * Support for runnig the demos , defaultSecurityParam , defaultDemoPraosParams @@ -30,16 +38,31 @@ module Ouroboros.Consensus.Demo ( , HasCreator(..) ) where +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) import Codec.Serialise (Serialise) +import qualified Codec.Serialise as Serialise import Control.Monad.Except -import Data.Either (fromRight) +import Crypto.Random (MonadRandom) +import qualified Data.Bimap as Bimap +import Data.Coerce import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Reflection (Given (..), give) import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import Ouroboros.Network.Block (SlotNo (..)) +import qualified Cardano.Chain.Block as Cardano.Block +import qualified Cardano.Chain.Genesis as Cardano.Genesis +import qualified Cardano.Chain.Slotting as Cardano.Slot +import qualified Cardano.Chain.Update as Cardano.Update +import qualified Cardano.Crypto as Cardano +import qualified Cardano.Crypto.Signing as Cardano.KeyGen + +import Ouroboros.Network.Block (BlockNo, ChainHash (..), HasHeader, + HeaderHash, SlotNo) +import Ouroboros.Network.BlockFetch (SizeInBytes) import Ouroboros.Consensus.Crypto.DSIGN import Ouroboros.Consensus.Crypto.DSIGN.Mock (verKeyIdFromSigned) @@ -47,7 +70,11 @@ import Ouroboros.Consensus.Crypto.Hash import Ouroboros.Consensus.Crypto.KES import Ouroboros.Consensus.Crypto.VRF import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.Mock +import Ouroboros.Consensus.Ledger.Byron +import qualified Ouroboros.Consensus.Ledger.Byron.Demo as ByronDemo +import Ouroboros.Consensus.Ledger.Mock (SimpleBlock, + SimpleBlockMockCrypto, SimpleHeader, SimplePreHeader) +import qualified Ouroboros.Consensus.Ledger.Mock as Mock import Ouroboros.Consensus.Mempool import Ouroboros.Consensus.Node (CoreNodeId (..), NodeId (..)) import Ouroboros.Consensus.Protocol.Abstract @@ -59,58 +86,65 @@ import Ouroboros.Consensus.Protocol.Praos import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense +import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy + {------------------------------------------------------------------------------- Abstract over the various protocols -------------------------------------------------------------------------------} type DemoBFT = Bft BftMockCrypto -type DemoPBFT = ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PBftMockCrypto) -type DemoPraos = ExtNodeConfig AddrDist (Praos PraosMockCrypto) +type DemoPraos = ExtNodeConfig Mock.AddrDist (Praos PraosMockCrypto) type DemoLeaderSchedule = WithLeaderSchedule (Praos PraosMockCrypto) +type DemoMockPBFT = ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PBftMockCrypto) +type DemoRealPBFT = ExtNodeConfig ByronDemo.Config (PBft PBftCardanoCrypto) -- | Consensus protocol to use -data DemoProtocol p where - DemoBFT :: SecurityParam -> DemoProtocol DemoBFT - DemoPBFT :: PBftParams -> DemoProtocol DemoPBFT - DemoPraos :: PraosParams -> DemoProtocol DemoPraos - DemoLeaderSchedule :: LeaderSchedule -> PraosParams -> DemoProtocol DemoLeaderSchedule - --- | Our 'Block' type stays the same. -type Block p = SimpleBlock p SimpleBlockMockCrypto - --- | Our 'Header' type stays the same. -type Header p = SimpleHeader p SimpleBlockMockCrypto +data DemoProtocol blk hdr where + -- | Run BFT against the mock ledger + DemoBFT + :: SecurityParam + -> DemoProtocol (SimpleBlock DemoBFT SimpleBlockMockCrypto) + (SimpleHeader DemoBFT SimpleBlockMockCrypto) + + -- | Run Praos against the mock ledger + DemoPraos + :: PraosParams + -> DemoProtocol (SimpleBlock DemoPraos SimpleBlockMockCrypto) + (SimpleHeader DemoPraos SimpleBlockMockCrypto) + + -- | Run Praos against the mock ledger but with an explicit leader schedule + DemoLeaderSchedule + :: LeaderSchedule + -> PraosParams + -> DemoProtocol (SimpleBlock DemoLeaderSchedule SimpleBlockMockCrypto) + (SimpleHeader DemoLeaderSchedule SimpleBlockMockCrypto) + + -- | Run PBFT against the mock ledger + DemoMockPBFT + :: PBftParams + -> DemoProtocol (SimpleBlock DemoMockPBFT SimpleBlockMockCrypto) + (SimpleHeader DemoMockPBFT SimpleBlockMockCrypto) + + -- | Run PBFT against the real ledger + DemoRealPBFT + :: PBftParams + -> Cardano.Genesis.Config + -> DemoProtocol (ByronBlock ByronDemo.Config) + (ByronHeader ByronDemo.Config) -- | Data required to run the specified protocol. -data ProtocolInfo p = ProtocolInfo { - pInfoConfig :: NodeConfig p +data ProtocolInfo b = ProtocolInfo { + pInfoConfig :: NodeConfig (BlockProtocol b) + , pInfoInitState :: NodeState (BlockProtocol b) -- | The ledger state at genesis - , pInfoInitLedger :: ExtLedgerState (Block p) - , pInfoInitState :: NodeState p + , pInfoInitLedger :: ExtLedgerState b } -type DemoProtocolConstraints p = ( - OuroborosTag p - , ProtocolLedgerView (Block p) - , HasCreator (Block p) - , Condense (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) - , Eq (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) - , Serialise (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) - , Show (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) - , ApplyTx (Block p) - ) - -demoProtocolConstraints :: DemoProtocol p -> Dict (DemoProtocolConstraints p) -demoProtocolConstraints DemoBFT{} = Dict -demoProtocolConstraints DemoPBFT{} = Dict -demoProtocolConstraints DemoPraos{} = Dict -demoProtocolConstraints DemoLeaderSchedule{} = Dict - newtype NumCoreNodes = NumCoreNodes Int deriving (Show) -- | Info needed to run the selected protocol -protocolInfo :: DemoProtocol p -> NumCoreNodes -> CoreNodeId -> ProtocolInfo p +protocolInfo :: DemoProtocol blk hdr -> NumCoreNodes -> CoreNodeId -> ProtocolInfo blk protocolInfo (DemoBFT securityParam) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = ProtocolInfo { pInfoConfig = BftNodeConfig { @@ -125,32 +159,12 @@ protocolInfo (DemoBFT securityParam) (NumCoreNodes numCoreNodes) (CoreNodeId nid | n <- [0 .. numCoreNodes - 1] ] } - , pInfoInitLedger = ExtLedgerState (genesisLedgerState addrDist) () - , pInfoInitState = () - } - where - addrDist :: AddrDist - addrDist = mkAddrDist numCoreNodes -protocolInfo (DemoPBFT params) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = - ProtocolInfo { - pInfoConfig = EncNodeConfig { - encNodeConfigP = PBftNodeConfig { - pbftParams = params { - pbftNumNodes = fromIntegral numCoreNodes - } - , pbftNodeId = CoreId nid - , pbftSignKey = SignKeyMockDSIGN nid - , pbftVerKey = VerKeyMockDSIGN nid - } - , encNodeConfigExt = PBftLedgerView - (Map.fromList [(VerKeyMockDSIGN n, VerKeyMockDSIGN n) | n <- [0 .. numCoreNodes - 1]]) - } - , pInfoInitLedger = ExtLedgerState (genesisLedgerState addrDist) ( Seq.empty, SlotNo 0 ) + , pInfoInitLedger = ExtLedgerState (Mock.genesisLedgerState addrDist) () , pInfoInitState = () } where - addrDist :: AddrDist - addrDist = mkAddrDist numCoreNodes + addrDist :: Mock.AddrDist + addrDist = Mock.mkAddrDist numCoreNodes protocolInfo (DemoPraos params) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = ProtocolInfo { pInfoConfig = EncNodeConfig { @@ -159,13 +173,13 @@ protocolInfo (DemoPraos params) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = , praosNodeId = CoreId nid , praosSignKeyVRF = SignKeyMockVRF nid , praosInitialEta = 0 - , praosInitialStake = genesisStakeDist addrDist + , praosInitialStake = Mock.genesisStakeDist addrDist , praosVerKeys = verKeys } , encNodeConfigExt = addrDist } , pInfoInitLedger = ExtLedgerState { - ledgerState = genesisLedgerState addrDist + ledgerState = Mock.genesisLedgerState addrDist , ouroborosChainState = [] } , pInfoInitState = SignKeyMockKES ( @@ -175,8 +189,8 @@ protocolInfo (DemoPraos params) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = ) } where - addrDist :: AddrDist - addrDist = mkAddrDist numCoreNodes + addrDist :: Mock.AddrDist + addrDist = Mock.mkAddrDist numCoreNodes verKeys :: IntMap (VerKeyKES MockKES, VerKeyVRF MockVRF) verKeys = IntMap.fromList [ (nd, (VerKeyMockKES nd, VerKeyMockVRF nd)) @@ -193,32 +207,94 @@ protocolInfo (DemoLeaderSchedule schedule params) , praosNodeId = CoreId nid , praosSignKeyVRF = SignKeyMockVRF nid , praosInitialEta = 0 - , praosInitialStake = genesisStakeDist addrDist + , praosInitialStake = Mock.genesisStakeDist addrDist , praosVerKeys = verKeys } , lsNodeConfigNodeId = CoreNodeId nid } , pInfoInitLedger = ExtLedgerState - { ledgerState = genesisLedgerState addrDist + { ledgerState = Mock.genesisLedgerState addrDist , ouroborosChainState = () } , pInfoInitState = () } where - addrDist = mkAddrDist numCoreNodes + addrDist = Mock.mkAddrDist numCoreNodes verKeys :: IntMap (VerKeyKES MockKES, VerKeyVRF MockVRF) verKeys = IntMap.fromList [ (nd, (VerKeyMockKES nd, VerKeyMockVRF nd)) | nd <- [0 .. numCoreNodes - 1] ] +protocolInfo (DemoMockPBFT params) + (NumCoreNodes numCoreNodes) + (CoreNodeId nid) = + ProtocolInfo { + pInfoConfig = EncNodeConfig { + encNodeConfigP = PBftNodeConfig { + pbftParams = params {pbftNumNodes = fromIntegral numCoreNodes} + , pbftNodeId = CoreId nid + , pbftSignKey = SignKeyMockDSIGN nid + , pbftVerKey = VerKeyMockDSIGN nid + } + , encNodeConfigExt = PBftLedgerView + (Bimap.fromList [(VerKeyMockDSIGN n, VerKeyMockDSIGN n) | n <- [0 .. numCoreNodes - 1]]) + } + , pInfoInitLedger = ExtLedgerState (Mock.genesisLedgerState addrDist) Seq.empty + , pInfoInitState = () + } + where + addrDist :: Mock.AddrDist + addrDist = Mock.mkAddrDist numCoreNodes -{- - data NodeConfig (WithLeaderSchedule p) = WLSNodeConfig - { lsNodeConfigWithLeaderSchedule :: LeaderSchedule - , lsNodeConfigP :: NodeConfig p - , lsNodeConfigNodeId :: Int - } - -} +protocolInfo (DemoRealPBFT params gc) + (NumCoreNodes numCoreNodes) + (CoreNodeId nid) = + ProtocolInfo { + pInfoConfig = EncNodeConfig { + encNodeConfigP = PBftNodeConfig { + pbftParams = params + { pbftNumNodes = fromIntegral numCoreNodes + -- Set the signature window to be short for the demo. + , pbftSignatureWindow = 7 + } + , pbftNodeId = CoreId nid + , pbftSignKey = SignKeyCardanoDSIGN (snd (lookupKey nid)) + , pbftVerKey = VerKeyCardanoDSIGN (fst (lookupKey nid)) + } + , encNodeConfigExt = ByronDemo.Config { + pbftCoreNodes = Bimap.fromList [ + (fst (lookupKey n), CoreNodeId n) + | n <- [0 .. numCoreNodes] + ] + , pbftProtocolMagic = Cardano.Genesis.configProtocolMagic gc + , pbftProtocolVersion = Cardano.Update.ProtocolVersion 1 0 0 + , pbftSoftwareVersion = Cardano.Update.SoftwareVersion (Cardano.Update.ApplicationName "Cardano Demo") 1 + , pbftGenesisConfig = gc + , pbftGenesisHash = coerce Cardano.Genesis.configGenesisHeaderHash gc + , pbftEpochSlots = Cardano.Genesis.configEpochSlots gc + , pbftGenesisDlg = Cardano.Genesis.configHeavyDelegation gc + , pbftSecrets = Dummy.dummyGeneratedSecrets + } + } + , pInfoInitLedger = ExtLedgerState { + ledgerState = ByronLedgerState { + blsCurrent = initState + , blsSnapshots = Seq.empty + } + , ouroborosChainState = Seq.empty + } + , pInfoInitState = () + } + where + initState :: Cardano.Block.ChainValidationState + Right initState = runExcept $ Cardano.Block.initialChainValidationState gc + + lookupKey :: Int -> (Cardano.VerificationKey, Cardano.SigningKey) + lookupKey n = (\x -> (Cardano.KeyGen.toVerification x, x)) + . (!! n) + . Cardano.Genesis.gsRichSecrets + . fromJust + $ Cardano.Genesis.configGeneratedSecrets gc {------------------------------------------------------------------------------- Support for running the demos @@ -251,66 +327,184 @@ enumCoreNodes (NumCoreNodes numNodes) = [ CoreNodeId n ] {------------------------------------------------------------------------------- - Parameters common to all protocols + Who created a block? -------------------------------------------------------------------------------} --- | Construct address to node ID mapping -mkAddrDist :: Int -- ^ Number of nodes - -> AddrDist -mkAddrDist numCoreNodes = - Map.fromList $ zip [[addr] | addr <- ['a'..]] - [CoreId n | n <- [0 .. numCoreNodes - 1]] - --- | Transaction giving initial stake to the nodes -genesisTx :: AddrDist -> Tx -genesisTx addrDist = Tx mempty [(addr, 1000) | addr <- Map.keys addrDist] - -genesisUtxo :: AddrDist -> Utxo -genesisUtxo addrDist = - fromRight (error "genesisLedger: invalid genesis tx") $ - runExcept (utxo (genesisTx addrDist)) - -genesisLedgerState :: AddrDist -> LedgerState (SimpleBlock p c) -genesisLedgerState addrDist = SimpleLedgerState { - slsUtxo = genesisUtxo addrDist - , slsConfirmed = Set.singleton (hash (genesisTx addrDist)) - } +class HasCreator b where + getCreator :: NodeConfig (BlockProtocol b) -> b -> CoreNodeId + +instance HasCreator (SimpleBlock DemoBFT c) where + getCreator _ = CoreNodeId + . verKeyIdFromSigned + . bftSignature + . Mock.headerOuroboros + . Mock.simpleHeader + +instance HasCreator (SimpleBlock DemoPraos c) where + getCreator _ = praosCreator + . praosExtraFields + . encPayloadP + . Mock.headerOuroboros + . Mock.simpleHeader + +instance HasCreator (SimpleBlock DemoLeaderSchedule c) where + getCreator _ = getWLSPayload + . Mock.headerOuroboros + . Mock.simpleHeader + +instance HasCreator (SimpleBlock DemoMockPBFT c) where + getCreator _ = CoreNodeId + . verKeyIdFromSigned + . pbftSignature + . encPayloadP + . Mock.headerOuroboros + . Mock.simpleHeader + +instance HasCreator (ByronBlock ByronDemo.Config) where + getCreator (EncNodeConfig _ ByronDemo.Config{..}) (ByronBlock b) = + fromMaybe (error "getCreator: unknown key") $ Bimap.lookup key pbftCoreNodes + where + key :: Cardano.VerificationKey + key = Cardano.pskIssuerVK + . Cardano.psigPsk + . Cardano.Block.unBlockSignature + . Cardano.Block.headerSignature + . Cardano.Block.blockHeader + $ b + +{------------------------------------------------------------------------------- + Additional functions needed to run the demo +-------------------------------------------------------------------------------} --- | Genesis stake distribution -genesisStakeDist :: AddrDist -> StakeDist -genesisStakeDist addrDist = - relativeStakes (totalStakes addrDist (genesisUtxo addrDist)) +class DemoHeaderHash hh where + demoEncodeHeaderHash :: hh -> Encoding + demoDecodeHeaderHash :: Decoder s hh + +class ( DemoHeaderHash (HeaderHash hdr) + , SupportedBlock (BlockProtocol hdr) hdr + , HasHeader hdr + , Condense hdr + , Condense (ChainHash hdr) + ) => DemoHeader hdr where + demoEncodeHeader :: NodeConfig (BlockProtocol hdr) -> hdr -> Encoding + demoDecodeHeader :: NodeConfig (BlockProtocol hdr) -> Decoder s hdr + demoBlockFetchSize :: hdr -> SizeInBytes + +class ( ProtocolLedgerView blk + , LedgerConfigView blk + , Condense blk + , Condense [blk] + , ApplyTx blk + , Show (Payload (BlockProtocol blk) (PreHeader blk)) + ) => DemoBlock blk where + demoEncodeBlock :: NodeConfig (BlockProtocol blk) -> blk -> Encoding + demoDecodeBlock :: forall s. NodeConfig (BlockProtocol blk) -> Decoder s blk + + -- | Construct transaction from mock transaction + -- + -- When we run the demo, for convenience we submit mock transactions from + -- the command line. These then need to be translated to "real" transactions + -- for the ledger that we are running. Of course, this translation will + -- necessarily be limited and will rely on things like 'generatedSecrets'. + demoMockTx :: NodeConfig (BlockProtocol blk) -> Mock.Tx -> GenTx blk + +class ( DemoHeader hdr + , DemoBlock blk + , BlockProtocol blk ~ BlockProtocol hdr + , HeaderHash blk ~ HeaderHash hdr + ) => RunDemo blk hdr where + demoForgeBlock :: (HasNodeState (BlockProtocol blk) m, MonadRandom m) + => NodeConfig (BlockProtocol blk) + -> SlotNo -- ^ Current slot + -> BlockNo -- ^ Current block number + -> ChainHash hdr -- ^ Previous hash + -> [GenTx blk] -- ^ Txs to add in the block + -> IsLeader (BlockProtocol blk) + -> m blk + demoGetHeader :: blk -> hdr + demoBlockMatchesHeader :: hdr -> blk -> Bool {------------------------------------------------------------------------------- - Who created a block? + RunDemo instance for the mock ledger -------------------------------------------------------------------------------} -class HasCreator b where - getCreator :: b -> CoreNodeId - -instance HasCreator (Block DemoBFT) where - getCreator = CoreNodeId - . verKeyIdFromSigned - . bftSignature - . headerOuroboros - . simpleHeader - -instance HasCreator (Block DemoPBFT) where - getCreator = CoreNodeId - . verKeyIdFromSigned - . pbftSignature - . encPayloadP - . headerOuroboros - . simpleHeader - -instance HasCreator (Block DemoPraos) where - getCreator = praosCreator - . praosExtraFields - . encPayloadP - . headerOuroboros - . simpleHeader - -instance HasCreator (Block DemoLeaderSchedule) where - getCreator = getWLSPayload - . headerOuroboros - . simpleHeader +instance HashAlgorithm h => DemoHeaderHash (Hash h a) where + demoEncodeHeaderHash = Serialise.encode + demoDecodeHeaderHash = Serialise.decode + +instance ( OuroborosTag p + , SupportedBlock p (SimpleHeader p SimpleBlockMockCrypto) + , Serialise (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) + , Condense (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) + ) => DemoHeader (SimpleHeader p SimpleBlockMockCrypto) where + demoEncodeHeader = const Serialise.encode + demoDecodeHeader = const Serialise.decode + demoBlockFetchSize = Mock.headerBlockSize . Mock.headerPreHeader + +instance ( OuroborosTag p + , ProtocolLedgerView (SimpleBlock p SimpleBlockMockCrypto) + , Condense (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) + , Serialise (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) + , Show (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) + ) => DemoBlock (SimpleBlock p SimpleBlockMockCrypto) where + demoEncodeBlock = const Serialise.encode + demoDecodeBlock = const Serialise.decode + demoMockTx = \_ -> Mock.SimpleGenTx + +instance ( OuroborosTag p + , ProtocolLedgerView (SimpleBlock p SimpleBlockMockCrypto) + , SupportedBlock p (SimpleHeader p SimpleBlockMockCrypto) + , Condense (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) + , Serialise (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) + , Show (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) + ) => RunDemo (SimpleBlock p SimpleBlockMockCrypto) + (SimpleHeader p SimpleBlockMockCrypto) where + demoForgeBlock = Mock.forgeSimpleBlock + demoGetHeader = Mock.simpleHeader + demoBlockMatchesHeader = Mock.blockMatchesHeader + +{------------------------------------------------------------------------------- + RunDemo instance for PBFT with the real ledger +-------------------------------------------------------------------------------} + +instance DemoHeaderHash Cardano.Block.HeaderHash where + demoEncodeHeaderHash = ByronDemo.encodeHeaderHash + demoDecodeHeaderHash = ByronDemo.decodeHeaderHash + +instance ( Given Cardano.Block.HeaderHash + , Given Cardano.Slot.EpochSlots + ) => DemoHeader (ByronHeader ByronDemo.Config) where + demoEncodeHeader = ByronDemo.encodeHeader + demoDecodeHeader = ByronDemo.decodeHeader + demoBlockFetchSize = const 2000 -- TODO #593 + +instance ( Given Cardano.Block.HeaderHash + , Given Cardano.ProtocolMagicId + , Given Cardano.Slot.EpochSlots + ) => DemoBlock (ByronBlock ByronDemo.Config) where + demoEncodeBlock = ByronDemo.encodeBlock + demoDecodeBlock = ByronDemo.decodeBlock + demoMockTx = ByronDemo.elaborateTx + +instance ( Given Cardano.Block.HeaderHash + , Given Cardano.ProtocolMagicId + , Given Cardano.Slot.EpochSlots + ) => RunDemo (ByronBlock ByronDemo.Config) + (ByronHeader ByronDemo.Config) where + demoForgeBlock = ByronDemo.forgeBlock + demoGetHeader = byronHeader + demoBlockMatchesHeader = \_hdr _blk -> True -- TODO #595 + +{------------------------------------------------------------------------------- + Evidence that we can run all the supported demos +-------------------------------------------------------------------------------} + +runDemo :: DemoProtocol blk hdr -> Dict (RunDemo blk hdr) +runDemo DemoBFT{} = Dict +runDemo DemoPraos{} = Dict +runDemo DemoLeaderSchedule{} = Dict +runDemo DemoMockPBFT{} = Dict +runDemo DemoRealPBFT{} = give (Dummy.dummyEpochSlots) + $ give (Cardano.Genesis.gdProtocolMagicId Dummy.dummyGenesisData) + $ give (coerce @_ @Cardano.Block.HeaderHash Dummy.dummyGenesisHash) + $ Dict diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs index 8d34f249663..d0d0656ba57 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -14,6 +17,7 @@ module Ouroboros.Consensus.Ledger.Abstract ( UpdateLedger(..) , BlockProtocol , ProtocolLedgerView(..) + , LedgerConfigView(..) -- * Extended ledger state , ExtLedgerState(..) , ExtValidationError(..) @@ -29,12 +33,12 @@ module Ouroboros.Consensus.Ledger.Abstract ( import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding) import Control.Monad.Except - -import Data.Word (Word64) +import GHC.Stack import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util (repeatedlyM) -import Ouroboros.Network.Block (HasHeader (..)) +import Ouroboros.Consensus.Util.SlotBounded (SlotBounded) +import Ouroboros.Network.Block (HasHeader (..), Point, SlotNo) import Ouroboros.Network.Chain (Chain, toOldestFirst) {------------------------------------------------------------------------------- @@ -47,45 +51,39 @@ class ( Show (LedgerState b) ) => UpdateLedger (b :: *) where data family LedgerState b :: * data family LedgerError b :: * - -- | The 'HeaderState' can be used to verify the headers of blocks using - -- 'advanceHeader'. - data family HeaderState b :: * - -- | Apply a block to the ledger state + -- | Static environment required for the ledger + data family LedgerConfig b :: * + + -- | Apply a block header to the ledger state. + -- + -- Used in 'applyExtLedgerState' to update the ledger state in 3 steps: + -- + -- 1. 'applyLedgerHeader' updates the ledger with information from the header + -- 2. 'applyChainState' updates the the consensus-specific chain state + -- This gets passed the updated ledger from step (1) as an argument + -- 3. 'applyLedgerBlock' updates the ledger with information from the body -- - -- TODO: We need to support rollback, so this probably won't be a pure - -- function but rather something that lives in a monad with some actions - -- that we can compute a "running diff" so that we can go back in time. - applyLedgerState :: b + -- TODO: Explain why this ordering is correct and why we need the split; + -- (3) does not seem to rely on (2), and so we could do (1), (3), (2), and if + -- that is indeed possible, we could just combine (1) and (3) into a single + -- step..? + -- + applyLedgerHeader :: LedgerConfig b + -> b + -> LedgerState b + -> Except (LedgerError b) (LedgerState b) + + -- | Apply a block to the ledger state + applyLedgerBlock :: LedgerConfig b + -> b -> LedgerState b -> Except (LedgerError b) (LedgerState b) - -- | Obtain from the given 'LedgerState' a 'HeaderState' corresponding to - -- some block in the past (relative to the given 'LedgerState'). - getHeaderState :: LedgerState b - -> Word64 -- ^ How many blocks in the past, max 2k slots - -> HeaderState b - - -- | Validate the given header and return the updated 'HeaderState', or, in - -- case of an invalid header, a 'LedgerError'. + -- | Point of the most recently applied block -- - -- For Ouroboros Classic, a 'HeaderState' can only be used for a window of - -- 2k slots forward and 2k slots backwards. So after advancing a - -- 'HeaderState' beyond the window, a new 'HeaderState' must be obtained - -- from the 'LedgerState'. Instead of burdening the user with this - -- responsibility, it is shifted to the __implementors__ of this method: - -- when the given 'HeaderState' is no longer valid (the user has advanced it - -- beyond the valid window), it must be ignored and a new 'HeaderState' must - -- be obtained from the 'LedgerState' and used to validate the header (and - -- returned). - advanceHeader :: HasHeader hdr - => LedgerState b - -> hdr - -> HeaderState b - -> Except (LedgerError b) (HeaderState b) - -- TODO make hdr a type parameter or a data/type family? - - + -- Should be 'genesisPoint' when no blocks have been applied yet + ledgerTipPoint :: LedgerState b -> Point b -- | Link blocks to their unique protocol type family BlockProtocol b :: * @@ -100,6 +98,57 @@ class ( OuroborosTag (BlockProtocol b) -> LedgerState b -> LedgerView (BlockProtocol b) + -- | Get a ledger view for a specific slot + -- + -- Suppose @k = 4@, i.e., we can roll back 4 blocks + -- + -- > /-----------\ + -- > | ^ + -- > v | + -- > --*--*--*--*--*--*--*-- + -- > | A B + -- > | + -- > \- A' + -- + -- In other words, this means that we can roll back from point B to point A, + -- and then roll forward to any block on any fork from A. Note that we can + -- /not/ roll back to any siblings of A (such as A'), as that would require + -- us to roll back at least @k + 1@ blocks, which we can't (by definition). + -- + -- Given a ledger state at point B, we should be able to verify any of the + -- headers (corresponding to the blocks) at point A or any of its successors + -- on any fork, up to some maximum distance from A. This distance can be + -- determined by the ledger, though must be at least @k@: we must be able to + -- validate any of these past headers, since otherwise we would not be able to + -- switch to a fork. It is not essential that the maximum distance extends + -- into the future (@> k@), though it is helpful: it means that in the chain + -- sync client we can download and validate headers even if they don't fit + -- directly onto the tip of our chain. + -- + -- The anachronistic ledger state at point B is precisely the ledger state + -- that can be used to validate this set of headers. The bounds (in terms of + -- slots) are a hint about its valid range: how far into the past can we look + -- (at least @k@) and how far into the future (depending on the maximum + -- distance supported by the ledger). It is however important to realize that + -- this is not a full specification: after all, blocks @A@ and @A'@ have the + -- same slot number, but @A@ can be validated using the anachronistic ledger + -- view at @B@ whereas @A'@ can not. + -- + -- Invariant: when calling this function with slot @s@ yields a + -- 'SlotBounded' @sb@, then @'atSlot' sb@ yields a 'Just'. + anachronisticProtocolLedgerView + :: NodeConfig (BlockProtocol b) + -> LedgerState b + -> SlotNo -- ^ Slot for which you would like a ledger view + -> Maybe (SlotBounded (LedgerView (BlockProtocol b))) + +-- | Extract the ledger environment from the node config +class ( UpdateLedger b + , OuroborosTag (BlockProtocol b) + ) => LedgerConfigView b where + ledgerConfigView :: NodeConfig (BlockProtocol b) + -> LedgerConfig b + {------------------------------------------------------------------------------- Extended ledger state -------------------------------------------------------------------------------} @@ -117,54 +166,61 @@ deriving instance ProtocolLedgerView b => Show (ExtLedgerState b) data ExtValidationError b = ExtValidationErrorLedger (LedgerError b) | ExtValidationErrorOuroboros (ValidationErr (BlockProtocol b)) - | ExtValidationErrorEnvelope -- TODO (check back pointers etc) deriving instance ProtocolLedgerView b => Show (ExtValidationError b) -applyExtLedgerState :: ProtocolLedgerView b - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig (BlockProtocol b) +applyExtLedgerState :: forall b. + ( LedgerConfigView b + , ProtocolLedgerView b + , HasCallStack + ) + => NodeConfig (BlockProtocol b) -> b -> ExtLedgerState b -> Except (ExtValidationError b) (ExtLedgerState b) -applyExtLedgerState toEnc cfg b ExtLedgerState{..} = do +applyExtLedgerState cfg b ExtLedgerState{..} = do ledgerState' <- withExcept ExtValidationErrorLedger $ - applyLedgerState b ledgerState + applyLedgerHeader (ledgerConfigView cfg) b ledgerState ouroborosChainState' <- withExcept ExtValidationErrorOuroboros $ applyChainState - toEnc cfg (protocolLedgerView cfg ledgerState') b ouroborosChainState - return $ ExtLedgerState ledgerState' ouroborosChainState' - -foldExtLedgerState :: ProtocolLedgerView b - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig (BlockProtocol b) + ledgerState'' <- withExcept ExtValidationErrorLedger $ + applyLedgerBlock (ledgerConfigView cfg) b ledgerState' + return $ ExtLedgerState ledgerState'' ouroborosChainState' + +foldExtLedgerState :: ( LedgerConfigView b + , ProtocolLedgerView b + , HasCallStack + ) + => NodeConfig (BlockProtocol b) -> [b] -- ^ Blocks to apply, oldest first -> ExtLedgerState b -> Except (ExtValidationError b) (ExtLedgerState b) -foldExtLedgerState toEnc = repeatedlyM . applyExtLedgerState toEnc +foldExtLedgerState = repeatedlyM . applyExtLedgerState --- TODO: This should check stuff like backpointers also -chainExtLedgerState :: ProtocolLedgerView b - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig (BlockProtocol b) +chainExtLedgerState :: ( LedgerConfigView b + , ProtocolLedgerView b + , HasCallStack + ) + => NodeConfig (BlockProtocol b) -> Chain b -> ExtLedgerState b -> Except (ExtValidationError b) (ExtLedgerState b) -chainExtLedgerState toEnc cfg = foldExtLedgerState toEnc cfg . toOldestFirst +chainExtLedgerState cfg = foldExtLedgerState cfg . toOldestFirst -- | Validation of an entire chain -verifyChain :: ProtocolLedgerView b - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig (BlockProtocol b) +verifyChain :: ( LedgerConfigView b + , ProtocolLedgerView b + ) + => NodeConfig (BlockProtocol b) -> ExtLedgerState b -> Chain b -> Bool -verifyChain toEnc cfg initSt c = - case runExcept (chainExtLedgerState toEnc cfg c initSt) of +verifyChain cfg initSt c = + case runExcept (chainExtLedgerState cfg c initSt) of Left _err -> False Right _st' -> True diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs new file mode 100644 index 00000000000..f23da75456d --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wredundant-constraints #-} + +module Ouroboros.Consensus.Ledger.Byron + ( -- * Byron blocks and headers + ByronBlock (..) + , ByronHeader (..) + , byronHeader + -- * Mempool integration + , GenTx (..) + -- * Ledger + , LedgerState (..) + , LedgerConfig (..) + ) where + +import Control.Monad.Except +import Data.Bifunctor (bimap, first) +import qualified Data.Bimap as Bimap +import Data.Coerce (coerce) +import Data.FingerTree (Measured (..)) +import Data.Foldable (find, foldl') +import Data.Reflection (Given (..)) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Text as T +import Data.Typeable +import Data.Word (Word8) +import Formatting + +import Cardano.Binary (Annotated (..), reAnnotate, toCBOR) +import qualified Cardano.Chain.Block as CC.Block +import qualified Cardano.Chain.Common as CC.Common +import qualified Cardano.Chain.Delegation as CC.Delegation +import qualified Cardano.Chain.Delegation.Validation.Interface as V.Interface +import qualified Cardano.Chain.Delegation.Validation.Scheduling as V.Scheduling +import qualified Cardano.Chain.Genesis as CC.Genesis +import qualified Cardano.Chain.Slotting as CC.Slot +import qualified Cardano.Chain.Update.Validation.Interface as CC.UPI +import qualified Cardano.Chain.UTxO as CC.UTxO +import qualified Cardano.Crypto as Crypto + +import Ouroboros.Network.Block +import Ouroboros.Network.Chain (genesisSlotNo) + +import Ouroboros.Consensus.Crypto.DSIGN +import Ouroboros.Consensus.Crypto.Hash +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Mempool.API +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.ExtNodeConfig +import Ouroboros.Consensus.Protocol.PBFT +import Ouroboros.Consensus.Util.Condense +import Ouroboros.Consensus.Util.SlotBounded (SlotBounded (..)) +import qualified Ouroboros.Consensus.Util.SlotBounded as SB + +{------------------------------------------------------------------------------- + Byron blocks and headers +-------------------------------------------------------------------------------} + +-- | Newtype wrapper to avoid orphan instances +-- +-- The phantom type parameter is there to record the additional information +-- we need to work with this block. Most of the code here does not care, +-- but we may need different additional information when running the chain +-- for real as when we are running the demo. +newtype ByronBlock cfg = ByronBlock + { unByronBlock :: CC.Block.ABlock ByteString + } + deriving (Eq, Show) + + +newtype ByronHeader cfg = ByronHeader + { unByronHeader :: CC.Block.AHeader ByteString + } deriving (Eq, Show) + + +byronHeader :: ByronBlock cfg -> ByronHeader cfg +byronHeader (ByronBlock b) = ByronHeader (CC.Block.blockHeader b) + + +{------------------------------------------------------------------------------- + HasHeader instances +-------------------------------------------------------------------------------} + +instance (Given CC.Block.HeaderHash, Typeable cfg) + => HasHeader (ByronBlock cfg) where + type HeaderHash (ByronBlock cfg) = CC.Block.HeaderHash + + blockHash = blockHash . byronHeader + blockPrevHash = castHash . blockPrevHash . byronHeader + blockSlot = blockSlot . byronHeader + blockNo = blockNo . byronHeader + blockInvariant = const True + +instance (Given CC.Block.HeaderHash, Typeable cfg) + => HasHeader (ByronHeader cfg) where + type HeaderHash (ByronHeader cfg) = CC.Block.HeaderHash + + -- Implementation of 'blockHash' derived from + -- + -- > blockHashAnnotated :: ABlock ByteString -> HeaderHash + -- > blockHashAnnotated = hashDecoded . fmap wrapHeaderBytes . blockHeader + -- + -- I couldn't find a version for headers + blockHash = Crypto.hashDecoded + . fmap CC.Block.wrapHeaderBytes + . unByronHeader + + -- We distinguish the genesis hash + -- + -- Note that on the actual chain, for real blocks the previous hash will + -- never be genesis, only for EBBs can it be genesis. We don't enforce that + -- here (makes stuff like the demo easier, and also means we could for + -- example run a shelley-only chain). + blockPrevHash (ByronHeader h) = case CC.Block.headerPrevHash h of + h' | h' == given -> GenesisHash + _ -> BlockHash $ CC.Block.headerPrevHash h + + blockSlot = convertSlot + . CC.Block.headerSlot + . unByronHeader + blockNo = BlockNo + . CC.Common.unChainDifficulty + . CC.Block.headerDifficulty + . unByronHeader + blockInvariant = const True + + +instance (Given CC.Block.HeaderHash, Typeable cfg) + => Measured BlockMeasure (ByronBlock cfg) where + measure = blockMeasure + +instance (Given CC.Block.HeaderHash, Typeable cfg) + => Measured BlockMeasure (ByronHeader cfg) where + measure = blockMeasure + +instance StandardHash (ByronBlock cfg) +instance StandardHash (ByronHeader cfg) + +{------------------------------------------------------------------------------- + Ledger +-------------------------------------------------------------------------------} + +instance UpdateLedger (ByronBlock cfg) where + + data LedgerState (ByronBlock cfg) = ByronLedgerState + { blsCurrent :: CC.Block.ChainValidationState + -- | Slot-bounded snapshots of the chain state + , blsSnapshots :: Seq.Seq (SlotBounded CC.Block.ChainValidationState) + } + deriving (Eq, Show) + + newtype LedgerError (ByronBlock cfg) + = ByronLedgerError CC.Block.ChainValidationError + deriving (Eq, Show) + + newtype LedgerConfig (ByronBlock cfg) = ByronLedgerConfig CC.Genesis.Config + + applyLedgerBlock (ByronLedgerConfig cfg) (ByronBlock block) + (ByronLedgerState state snapshots) = + mapExcept (first ByronLedgerError) $ do + CC.Block.BodyState { CC.Block.utxo, CC.Block.updateState + , CC.Block.delegationState } + <- CC.Block.updateBody bodyEnv bodyState block + let state' = state + { CC.Block.cvsLastSlot = CC.Block.blockSlot block + , CC.Block.cvsPreviousHash = Right $ CC.Block.blockHashAnnotated block + , CC.Block.cvsUtxo = utxo + , CC.Block.cvsUpdateState = updateState + , CC.Block.cvsDelegationState = delegationState + } + snapshots' + | CC.Block.cvsDelegationState state' == + CC.Block.cvsDelegationState state + = snapshots + | otherwise + = snapshots Seq.|> SB.bounded startOfSnapshot slot state' + where + startOfSnapshot = case snapshots of + _ Seq.:|> a -> sbUpper a + Seq.Empty -> SlotNo 0 + slot = convertSlot $ CC.Block.blockSlot block + return $ ByronLedgerState state' (trimSnapshots snapshots') + where + bodyState = CC.Block.BodyState + { CC.Block.utxo = CC.Block.cvsUtxo state + , CC.Block.updateState = CC.Block.cvsUpdateState state + , CC.Block.delegationState = CC.Block.cvsDelegationState state + } + bodyEnv = CC.Block.BodyEnvironment + { CC.Block.protocolMagic = fixPM $ CC.Genesis.configProtocolMagic cfg + , CC.Block.k = CC.Genesis.configK cfg + , CC.Block.numGenKeys = numGenKeys cfg + , CC.Block.protocolParameters = protocolParameters + , CC.Block.currentEpoch = CC.Slot.slotNumberEpoch + (CC.Genesis.configEpochSlots cfg) + (CC.Block.blockSlot block) + } + + protocolParameters = CC.UPI.adoptedProtocolParameters . CC.Block.cvsUpdateState + $ state + + fixPM (Crypto.AProtocolMagic a b) = Crypto.AProtocolMagic (reAnnotate a) b + + k = CC.Genesis.configK cfg + + trimSnapshots = Seq.dropWhileL $ \ss -> + sbUpper ss < convertSlot (CC.Block.blockSlot block) - 2 * coerce k + + applyLedgerHeader (ByronLedgerConfig cfg) (ByronBlock block) + (ByronLedgerState state snapshots) = + mapExcept (bimap ByronLedgerError (\i -> ByronLedgerState i snapshots)) $ do + updateState <- CC.Block.updateHeader + headerEnv + (CC.Block.cvsUpdateState state) + (CC.Block.blockHeader block) + return $ state + { CC.Block.cvsLastSlot = CC.Block.blockSlot block + , CC.Block.cvsPreviousHash = Right $ CC.Block.blockHashAnnotated block + , CC.Block.cvsUpdateState = updateState + } + where + headerEnv = CC.Block.HeaderEnvironment + { CC.Block.protocolMagic = fixPMI $ CC.Genesis.configProtocolMagicId cfg + , CC.Block.k = CC.Genesis.configK cfg + , CC.Block.numGenKeys = numGenKeys cfg + , CC.Block.delegationMap = delegationMap + , CC.Block.lastSlot = CC.Block.cvsLastSlot state + } + delegationMap = V.Interface.delegationMap + $ CC.Block.cvsDelegationState state + + fixPMI pmi = reAnnotate $ Annotated pmi () + + ledgerTipPoint (ByronLedgerState state _) = Point + { pointSlot = convertSlot (CC.Block.cvsLastSlot state) + , pointHash = case CC.Block.cvsPreviousHash state of + Left _genHash -> GenesisHash + Right hdrHash -> BlockHash hdrHash + } + +numGenKeys :: CC.Genesis.Config -> Word8 +numGenKeys cfg = case length genKeys of + n | n > fromIntegral (maxBound :: Word8) + -> error "updateBody: Too many genesis keys" + | otherwise + -> fromIntegral n + where + genKeys :: Set CC.Common.KeyHash + genKeys = CC.Genesis.unGenesisKeyHashes + . CC.Genesis.configGenesisKeyHashes + $ cfg + +{------------------------------------------------------------------------------- + Support for PBFT consensus algorithm +-------------------------------------------------------------------------------} + +instance (Given CC.Block.HeaderHash, Given CC.Slot.EpochSlots, Typeable cfg) + => BlockSupportsPBft PBftCardanoCrypto (ByronBlock cfg) + +type instance BlockProtocol (ByronBlock cfg) = + ExtNodeConfig cfg (PBft PBftCardanoCrypto) + +type instance BlockProtocol (ByronHeader cfg) = + ExtNodeConfig cfg (PBft PBftCardanoCrypto) + +instance (Given CC.Slot.EpochSlots, Given CC.Block.HeaderHash, Typeable cfg) + => HasPreHeader (ByronBlock cfg) where + type PreHeader (ByronBlock cfg) = CC.Block.ToSign + blockPreHeader = unAnnotated + . CC.Block.recoverSignedBytes given + . CC.Block.blockHeader + . unByronBlock + encodePreHeader = const toCBOR + +-- TODO get rid of this once we have a BlockHeader type family +instance (Given CC.Slot.EpochSlots, Given CC.Block.HeaderHash, Typeable cfg) + => HasPreHeader (ByronHeader cfg) where + type PreHeader (ByronHeader cfg) = CC.Block.ToSign + blockPreHeader = unAnnotated + . CC.Block.recoverSignedBytes given + . unByronHeader + encodePreHeader = const toCBOR + +-- TODO get rid of this once we have a BlockHeader type family +instance (Given CC.Slot.EpochSlots, Given CC.Block.HeaderHash, Typeable cfg) + => HasPayload (PBft PBftCardanoCrypto) (ByronHeader cfg) where + blockPayload _ (ByronHeader header) = PBftPayload + { pbftIssuer = VerKeyCardanoDSIGN + . Crypto.pskDelegateVK + . Crypto.psigPsk + . CC.Block.unBlockSignature + . CC.Block.headerSignature + $ header + , pbftSignature = SignedDSIGN + . SigCardanoDSIGN + . Crypto.Signature + . Crypto.psigSig + . CC.Block.unBlockSignature + . CC.Block.headerSignature + $ header + } + +instance (Given CC.Slot.EpochSlots, Given CC.Block.HeaderHash, Typeable cfg) + => HasPayload (PBft PBftCardanoCrypto) (ByronBlock cfg) where + blockPayload cfg = blockPayload cfg . byronHeader + +instance ( Given Crypto.ProtocolMagicId + , Given CC.Slot.EpochSlots + , Given CC.Block.HeaderHash + , Typeable cfg + ) => ProtocolLedgerView (ByronBlock cfg) where + protocolLedgerView _ns (ByronLedgerState ls _) + = PBftLedgerView + . CC.Delegation.unMap + . V.Interface.delegationMap + . CC.Block.cvsDelegationState + $ ls + + -- There are two cases here: + -- + -- - The view we want is in the past. In this case, we attempt to find a + -- snapshot which contains the relevant slot, and extract the delegation + -- map from that. + -- + -- - The view we want is in the future. In this case, we need to check the + -- upcoming delegations to see what new delegations will be made in the + -- future, and update the current delegation map based on that. + anachronisticProtocolLedgerView cfg (ByronLedgerState ls ss) slot = + case find (containsSlot slot) ss of + -- We can find a snapshot which supports this slot + Just sb -> Just + $ PBftLedgerView + . CC.Delegation.unMap + . V.Interface.delegationMap + . CC.Block.cvsDelegationState + <$> sb + -- No snapshot - we could be in the past or in the future + Nothing + | slot >= lvLB && slot <= lvUB + -> Just $ PBftLedgerView <$> + case Seq.takeWhileL + (\sd -> convertSlot (V.Scheduling.sdSlot sd) <= slot) + dsScheduled of + -- No updates to apply. So the current ledger state is valid + -- from the end of the last snapshot to the first scheduled + -- update. + Seq.Empty -> SB.bounded lb ub dsNow + toApply@(_ Seq.:|> la) -> + SB.bounded lb (convertSlot . V.Scheduling.sdSlot $ la) $ + foldl' + (\acc x -> Bimap.insert (V.Scheduling.sdDelegator x) + (V.Scheduling.sdDelegate x) + acc) + dsNow toApply + | otherwise + -> Nothing + where + lb = case ss of + _ Seq.:|> s -> max lvLB (sbUpper s) + Seq.Empty -> lvLB + ub = case dsScheduled of + s Seq.:<| _ -> min lvUB (convertSlot $ V.Scheduling.sdSlot s) + Seq.Empty -> lvUB + + SecurityParam paramK = pbftSecurityParam . pbftParams . encNodeConfigP $ cfg + + lvUB = SlotNo $ unSlotNo currentSlot + (2 * paramK) + lvLB + | 2 * paramK > unSlotNo currentSlot + = genesisSlotNo + | otherwise + = SlotNo $ unSlotNo currentSlot - (2 * paramK) + + dsNow = CC.Delegation.unMap + . V.Interface.delegationMap + . CC.Block.cvsDelegationState + $ ls + dsScheduled = V.Scheduling.scheduledDelegations + . V.Interface.schedulingState + . CC.Block.cvsDelegationState + $ ls + currentSlot = convertSlot $ CC.Block.cvsLastSlot ls + containsSlot s sb = sbLower sb <= s && sbUpper sb >= s + +{------------------------------------------------------------------------------- + Mempool integration +-------------------------------------------------------------------------------} + +instance ApplyTx (ByronBlock cfg) where + -- | Generalized transactions in Byron + -- + -- TODO #514: This is still missing the other cases (this shouldn't be a + -- newtype) + data GenTx (ByronBlock cfg) = ByronTx { unByronTx :: CC.UTxO.ATxAux ByteString } + + type ApplyTxErr (ByronBlock cfg) = CC.UTxO.UTxOValidationError + + applyTx = applyByronGenTx False + reapplyTx = applyByronGenTx True + + -- TODO #440: We need explicit support for this from the ledger + -- (though during testing we might still want to actually verify that we + -- didn't get any errors) + reapplyTxSameState cfg tx st = + case runExcept (applyByronGenTx True cfg tx st) of + Left err -> error $ "unexpected error: " <> show err + Right st' -> st' + +applyByronGenTx :: Bool -- ^ Have we verified this transaction previously? + -> LedgerConfig (ByronBlock cfg) + -> GenTx (ByronBlock cfg) + -> LedgerState (ByronBlock cfg) + -> Except CC.UTxO.UTxOValidationError + (LedgerState (ByronBlock cfg)) +applyByronGenTx _reapply (ByronLedgerConfig cfg) genTx st@ByronLedgerState{..} = + (\x -> st { blsCurrent = x }) <$> go genTx blsCurrent + where + go :: GenTx (ByronBlock cfg) + -> CC.Block.ChainValidationState + -> Except CC.UTxO.UTxOValidationError CC.Block.ChainValidationState + go (ByronTx tx) cvs = wrapCVS <$> CC.UTxO.updateUTxO env utxo [tx] + where + wrapCVS newUTxO = cvs { CC.Block.cvsUtxo = newUTxO } + protocolMagic = fixPM $ CC.Genesis.configProtocolMagic cfg + utxo = CC.Block.cvsUtxo cvs + updateState = CC.Block.cvsUpdateState cvs + env = CC.UTxO.Environment + { CC.UTxO.protocolMagic = protocolMagic + , CC.UTxO.protocolParameters = CC.UPI.adoptedProtocolParameters updateState + } + fixPM (Crypto.AProtocolMagic a b) = Crypto.AProtocolMagic (reAnnotate a) b + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +convertSlot :: CC.Slot.FlatSlotId -> SlotNo +convertSlot = coerce + +{------------------------------------------------------------------------------- + Condense instances +-------------------------------------------------------------------------------} + +instance Condense (ByronBlock cfg) where + condense blk = + "(header: " <> condensedHeader <> + ", body: " <> condensedBody <> + ")" + where + condensedHeader = condense + . byronHeader + $ blk + condensedBody = T.unpack + . sformat build + . CC.UTxO.txpTxs + . CC.Block.bodyTxPayload + . CC.Block.blockBody + . unByronBlock + $ blk + +instance Condense (ByronHeader cfg) where + condense hdr = + "(hash: " <> condensedHash <> + ", previousHash: " <> condensedPrevHash <> + ", slot: " <> condensedSlot <> + ", issuer: " <> condenseKey issuer <> + ", delegate: " <> condenseKey delegate <> + ")" + where + psigPsk = Crypto.psigPsk + . CC.Block.unBlockSignature + . CC.Block.headerSignature + . unByronHeader + $ hdr + issuer = Crypto.pskIssuerVK psigPsk + delegate = Crypto.pskDelegateVK psigPsk + + condenseKey :: Crypto.VerificationKey -> String + condenseKey = T.unpack . sformat build + + condensedHash + = T.unpack + . sformat CC.Block.headerHashF + . Crypto.hashDecoded . fmap CC.Block.wrapHeaderBytes + . unByronHeader + $ hdr + + condensedPrevHash + = T.unpack + . sformat CC.Block.headerHashF + . CC.Block.headerPrevHash + . unByronHeader + $ hdr + + condensedSlot + = T.unpack + . sformat build + . unAnnotated + . CC.Block.aHeaderSlot + . unByronHeader + $ hdr + +instance Condense (ChainHash (ByronHeader cfg)) where + condense GenesisHash = "genesis" + condense (BlockHash h) = show h diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs new file mode 100644 index 00000000000..dfb55cbdecc --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ouroboros.Consensus.Ledger.Byron.Demo + ( -- * Running Byron in the demo + Config (..) + , ByronExtNodeConfig + -- * Forging a new block + , forgeBlock + -- * Elaboration from our mock transactions into transactions on the real ledger + , elaborateTx + -- * Serialisation + , encodeHeader + , encodeBlock + , encodeHeaderHash + , decodeHeader + , decodeBlock + , decodeHeaderHash + ) where + +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) +import qualified Codec.CBOR.Read as CBOR +import qualified Codec.CBOR.Write as CBOR +import Control.Monad (void) +import Crypto.Random (MonadRandom) +import Data.Bifunctor (bimap) +import Data.Bimap (Bimap) +import qualified Data.ByteString.Lazy as Lazy +import Data.Coerce (coerce) +import Data.Foldable (find) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Reflection (Given (..)) +import qualified Data.Set as Set +import Data.Typeable +import qualified Data.Vector as V + +import GHC.Stack (HasCallStack) + +import Cardano.Binary (Annotated (..), ByteSpan, fromCBOR, reAnnotate, + slice, toCBOR) +import qualified Cardano.Chain.Block as CC.Block +import qualified Cardano.Chain.Common as CC.Common +import qualified Cardano.Chain.Delegation as CC.Delegation +import qualified Cardano.Chain.Genesis as CC.Genesis +import qualified Cardano.Chain.Slotting as CC.Slot +import qualified Cardano.Chain.Ssc as CC.Ssc +import qualified Cardano.Chain.Update as CC.Update +import qualified Cardano.Chain.UTxO as CC.UTxO +import qualified Cardano.Crypto as Crypto + +import Ouroboros.Network.Block + +import Ouroboros.Consensus.Crypto.DSIGN +import Ouroboros.Consensus.Crypto.Hash +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Byron +import qualified Ouroboros.Consensus.Ledger.Mock as Mock +import Ouroboros.Consensus.Node (CoreNodeId) +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.ExtNodeConfig +import Ouroboros.Consensus.Protocol.PBFT + +{------------------------------------------------------------------------------- + Running Byron in the demo +-------------------------------------------------------------------------------} + +instance (Given CC.Block.HeaderHash, Given CC.Slot.EpochSlots) + => BlockSupportsPBft PBftCardanoCrypto (ByronHeader Config) + +-- Extended configuration we need for the demo +data Config = Config { + -- | Mapping from generic keys to core node IDs + -- + -- The keys in this map are the verification keys of the core nodes - that + -- is, the delegates of the genesis keys. + pbftCoreNodes :: Bimap Crypto.VerificationKey CoreNodeId + , pbftProtocolMagic :: Crypto.ProtocolMagic + , pbftProtocolVersion :: CC.Update.ProtocolVersion + , pbftSoftwareVersion :: CC.Update.SoftwareVersion + , pbftEpochSlots :: CC.Slot.EpochSlots + , pbftGenesisConfig :: CC.Genesis.Config + , pbftGenesisHash :: CC.Genesis.GenesisHash + , pbftGenesisDlg :: CC.Genesis.GenesisDelegation + , pbftSecrets :: CC.Genesis.GeneratedSecrets + } + +type ByronExtNodeConfig = ExtNodeConfig Config (PBft PBftCardanoCrypto) + +instance (Given Crypto.ProtocolMagicId) + => LedgerConfigView (ByronBlock Config) where + ledgerConfigView EncNodeConfig{..} = ByronLedgerConfig $ + pbftGenesisConfig encNodeConfigExt + +{------------------------------------------------------------------------------- + Forging a new block +-------------------------------------------------------------------------------} + +forgeBlock + :: forall m cfg. + ( HasNodeState_ () m -- @()@ is the @NodeState@ of PBFT + , MonadRandom m + , Given Crypto.ProtocolMagicId + , Given CC.Block.HeaderHash + , Given CC.Slot.EpochSlots + , Typeable cfg + ) + => NodeConfig ByronExtNodeConfig + -> SlotNo -- ^ Current slot + -> BlockNo -- ^ Current block number + -> ChainHash (ByronHeader cfg) -- ^ Previous hash + -> [GenTx (ByronBlock cfg)] -- ^ Txs to add in the block + -> () -- ^ Leader proof ('IsLeader') + -> m (ByronBlock Config) +forgeBlock cfg curSlot curNo prevHash txs () = do + ouroborosPayload <- mkPayload (Proxy @(ByronBlock cfg)) cfg () preHeader + return $ forge ouroborosPayload + where + Config {..} = encNodeConfigExt cfg + + txPayload :: CC.UTxO.TxPayload + txPayload = CC.UTxO.mkTxPayload (map (void . unByronTx) txs) + + body :: CC.Block.Body + body = CC.Block.ABody { + CC.Block.bodyTxPayload = txPayload + , CC.Block.bodySscPayload = CC.Ssc.SscPayload + , CC.Block.bodyDlgPayload = CC.Delegation.UnsafeAPayload [] () + , CC.Block.bodyUpdatePayload = CC.Update.APayload Nothing [] () + } + + proof :: CC.Block.Proof + proof = CC.Block.mkProof body + + prevHeaderHash :: CC.Block.HeaderHash + prevHeaderHash = case prevHash of + GenesisHash -> CC.Block.genesisHeaderHash pbftGenesisHash + BlockHash h -> h + + slotId :: CC.Slot.SlotId + slotId = CC.Slot.unflattenSlotId pbftEpochSlots $ coerce curSlot + + preHeader :: CC.Block.ToSign + preHeader = CC.Block.ToSign { + CC.Block.tsHeaderHash = prevHeaderHash + , CC.Block.tsSlot = slotId + , CC.Block.tsDifficulty = coerce curNo + , CC.Block.tsBodyProof = proof + , CC.Block.tsProtocolVersion = pbftProtocolVersion + , CC.Block.tsSoftwareVersion = pbftSoftwareVersion + } + + forge :: Payload ByronExtNodeConfig CC.Block.ToSign -> ByronBlock Config + forge ouroborosPayload = + ByronBlock $ annotateBlock pbftEpochSlots block + where + block :: CC.Block.Block + block = CC.Block.ABlock { + CC.Block.blockHeader = header + , CC.Block.blockBody = body + , CC.Block.blockAnnotation = () + } + + headerGenesisKey :: Crypto.VerificationKey + dlgCertificate :: CC.Delegation.Certificate + (headerGenesisKey, dlgCertificate) = case findDelegate of + Just x -> x + Nothing -> error "Issuer is not a valid genesis key delegate." + where + dlgMap = CC.Genesis.unGenesisDelegation pbftGenesisDlg + VerKeyCardanoDSIGN issuer = pbftIssuer . encPayloadP $ ouroborosPayload + findDelegate = fmap (\crt -> (Crypto.pskIssuerVK crt, crt)) + . find (\crt -> Crypto.pskDelegateVK crt == issuer) + $ Map.elems dlgMap + + headerSignature :: CC.Block.BlockSignature + headerSignature = CC.Block.BlockSignature + $ Crypto.AProxySignature dlgCertificate (coerce sig) + where + sig :: Crypto.Signature Encoding + SignedDSIGN (SigCardanoDSIGN sig) = pbftSignature $ encPayloadP ouroborosPayload + + header :: CC.Block.Header + header = CC.Block.AHeader { + CC.Block.aHeaderProtocolMagicId = ann (Crypto.getProtocolMagicId pbftProtocolMagic) + , CC.Block.aHeaderPrevHash = ann prevHeaderHash + , CC.Block.aHeaderSlot = ann (coerce curSlot) + , CC.Block.aHeaderDifficulty = ann (coerce curNo) + , CC.Block.headerProtocolVersion = pbftProtocolVersion + , CC.Block.headerSoftwareVersion = pbftSoftwareVersion + , CC.Block.aHeaderProof = ann proof + , CC.Block.headerGenesisKey = headerGenesisKey + , CC.Block.headerSignature = headerSignature + , CC.Block.headerAnnotation = () + , CC.Block.headerExtraAnnotation = () + } + + ann :: b -> Annotated b () + ann b = Annotated b () + +{------------------------------------------------------------------------------- + Elaboration from our mock transactions into transactions on the real ledger +-------------------------------------------------------------------------------} + +-- | Elaborate a mock transaction to a real one +-- +-- For now the only thing we support are transactions of the form +-- +-- > Tx (Set.singleton (_hash, n)) [(addr, amount)] +-- +-- We ignore the hash, and assume it refers to the initial balance of the @n@'th +-- rich actor. We then transfer it _to_ the @m@'s rich actor (with "a" being the +-- first rich actor), leaving any remaining balance simply as the transaction +-- fee. +-- +-- This is adapted from 'Test.Cardano.Chain.Elaboration.UTxO.elaborateTxWits' +elaborateTx :: HasCallStack + => NodeConfig ByronExtNodeConfig + -> Mock.Tx -> GenTx (ByronBlock cfg) +elaborateTx cfg (Mock.Tx ins outs) = + ByronTx $ CC.UTxO.ATxAux (annotate tx) (annotate witness) + where + annotate x = reAnnotate $ Annotated x () + -- mockInp and mockOut in [0 .. 3] (index of rich actor) + [(_hash, mockInp)] = Set.toList ins + [(mockAddr, mockVal)] = outs + + mockOut :: HasCallStack => Int + mockOut = case lookup mockAddr (zip ["a", "b", "c", "d"] [0..]) of + Nothing -> error "supported addresses: 'a', 'b', 'c' or 'd'" + Just i -> i + + tx :: CC.UTxO.Tx + tx = CC.UTxO.UnsafeTx { + txInputs = txIn :| [] + , txOutputs = txOut :| [] + , txAttributes = CC.Common.mkAttributes () + } + + txIn :: CC.UTxO.TxIn + txIn = fst . fst $ initialUtxo Map.! mockInp + + txOut :: CC.UTxO.TxOut + txOut = CC.UTxO.TxOut { + txOutAddress = CC.UTxO.txOutAddress $ snd . fst $ initialUtxo Map.! mockOut + , txOutValue = assumeBound $ + CC.Common.mkLovelace (fromIntegral (mockVal * 1000000)) + } + + witness :: CC.UTxO.TxWitness + witness = V.fromList [ + CC.UTxO.VKWitness + (Crypto.toVerification (snd $ initialUtxo Map.! mockInp)) + (Crypto.sign + (Crypto.getProtocolMagicId . pbftProtocolMagic . encNodeConfigExt $ cfg) + Crypto.SignTx + (snd $ initialUtxo Map.! mockInp) + (CC.UTxO.TxSigData (Crypto.hash tx)) + ) + ] + + -- UTxO in the genesis block for the rich men + initialUtxo :: Map Int ((CC.UTxO.TxIn, CC.UTxO.TxOut), Crypto.SigningKey) + initialUtxo = + Map.fromList + . mapMaybe (\(inp, out) -> mkEntry inp out <$> isRichman out) + . fromCompactTxInTxOutList + . Map.toList + . CC.UTxO.unUTxO + . CC.UTxO.genesisUtxo + $ pbftGenesisConfig (encNodeConfigExt cfg) + where + mkEntry :: CC.UTxO.TxIn + -> CC.UTxO.TxOut + -> (Int, Crypto.SigningKey) + -> (Int, ((CC.UTxO.TxIn, CC.UTxO.TxOut), Crypto.SigningKey)) + mkEntry inp out (richman, key) = (richman, ((inp, out), key)) + + isRichman :: CC.UTxO.TxOut -> Maybe (Int, Crypto.SigningKey) + isRichman out = listToMaybe $ filter (isValidKey . snd) richmen + where + isValidKey :: Crypto.SigningKey -> Bool + isValidKey key = + CC.Common.checkVerKeyAddress + (Crypto.toVerification key) + (CC.UTxO.txOutAddress out) + + richmen :: [(Int, Crypto.SigningKey)] + richmen = + zip [0..] $ + CC.Genesis.gsRichSecrets $ pbftSecrets (encNodeConfigExt cfg) + + fromCompactTxInTxOutList :: [(CC.UTxO.CompactTxIn, CC.UTxO.CompactTxOut)] + -> [(CC.UTxO.TxIn, CC.UTxO.TxOut)] + fromCompactTxInTxOutList = + map (bimap CC.UTxO.fromCompactTxIn CC.UTxO.fromCompactTxOut) + + assumeBound :: Either CC.Common.LovelaceError CC.Common.Lovelace + -> CC.Common.Lovelace + assumeBound (Left _err) = error "elaborateTx: too much" + assumeBound (Right ll) = ll + +{------------------------------------------------------------------------------- + Add annotation +-------------------------------------------------------------------------------} + +annotateBlock :: CC.Slot.EpochSlots -> CC.Block.Block -> CC.Block.ABlock ByteString +annotateBlock epochSlots = + (\bs -> splice bs (CBOR.deserialiseFromBytes (CC.Block.fromCBORABlock epochSlots) bs)) + . CBOR.toLazyByteString + . CC.Block.toCBORBlock epochSlots + where + splice :: Lazy.ByteString + -> Either err (Lazy.ByteString, CC.Block.ABlock ByteSpan) + -> CC.Block.ABlock ByteString + splice _ (Left _err) = + error "annotateBlock: serialization roundtrip failure" + splice bs (Right (_leftover, txAux)) = + (Lazy.toStrict . slice bs) <$> txAux + +annotateHeader :: CC.Slot.EpochSlots -> CC.Block.Header -> CC.Block.AHeader ByteString +annotateHeader epochSlots = + (\bs -> splice bs (CBOR.deserialiseFromBytes (CC.Block.fromCBORAHeader epochSlots) bs)) + . CBOR.toLazyByteString + . CC.Block.toCBORHeader epochSlots + where + splice :: Lazy.ByteString + -> Either err (Lazy.ByteString, CC.Block.AHeader ByteSpan) + -> CC.Block.AHeader ByteString + splice _ (Left _err) = + error "annotateBlock: serialization roundtrip failure" + splice bs (Right (_leftover, txAux)) = + (Lazy.toStrict . slice bs) <$> txAux + +{------------------------------------------------------------------------------- + Serialisation +-------------------------------------------------------------------------------} + +encodeHeader :: NodeConfig ByronExtNodeConfig + -> ByronHeader Config -> Encoding +encodeHeader cfg = + CC.Block.toCBORHeader epochSlots + . void + . unByronHeader + where + epochSlots = pbftEpochSlots (encNodeConfigExt cfg) + +encodeBlock :: NodeConfig ByronExtNodeConfig + -> ByronBlock Config -> Encoding +encodeBlock cfg = + CC.Block.toCBORBlock epochSlots + . void + . unByronBlock + where + epochSlots = pbftEpochSlots (encNodeConfigExt cfg) + +encodeHeaderHash :: HeaderHash (ByronHeader Config) -> Encoding +encodeHeaderHash = toCBOR + +decodeHeader :: NodeConfig ByronExtNodeConfig + -> Decoder s (ByronHeader Config) +decodeHeader cfg = + ByronHeader . annotate <$> CC.Block.fromCBORAHeader epochSlots + where + -- TODO #560: Re-annotation can be done but requires some rearranging in + -- the codecs Original ByteSpan's refer to bytestring we don't have, so + -- we'll ignore them + annotate :: CC.Block.AHeader a -> CC.Block.AHeader ByteString + annotate = annotateHeader epochSlots . void + + epochSlots = pbftEpochSlots (encNodeConfigExt cfg) + +decodeBlock :: NodeConfig ByronExtNodeConfig + -> Decoder s (ByronBlock Config) +decodeBlock cfg = + ByronBlock . annotate <$> CC.Block.fromCBORABlock epochSlots + where + -- TODO #560: Re-annotation can be done but requires some rearranging in + -- the codecs Original ByteSpan's refer to bytestring we don't have, so + -- we'll ignore them + annotate :: CC.Block.ABlock a -> CC.Block.ABlock ByteString + annotate = annotateBlock epochSlots . void + + epochSlots = pbftEpochSlots (encNodeConfigExt cfg) + +decodeHeaderHash :: Decoder s (HeaderHash (ByronHeader Config)) +decodeHeaderHash = fromCBOR diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs index 75271558a04..223f076fdda 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs @@ -31,14 +31,21 @@ module Ouroboros.Consensus.Ledger.Mock ( , SimpleHeader(..) , SimplePreHeader(..) , SimpleBody(..) - , forgeBlock + , forgeSimpleBlock , blockMatchesHeader + -- * Mempool + , GenTx(..) -- * Updating the Ledger state , LedgerState(..) - , HeaderState(..) , AddrDist , relativeStakes , totalStakes + -- * Compute protocol parameters + , mkAddrDist + , genesisTx + , genesisUtxo + , genesisLedgerState + , genesisStakeDist ) where import Codec.CBOR.Decoding (decodeListLenOf) @@ -47,6 +54,7 @@ import Codec.Serialise import Control.Monad.Except import Crypto.Random (MonadRandom) import qualified Data.ByteString.Lazy as BL +import Data.Either (fromRight) import Data.FingerTree (Measured (measure)) import qualified Data.IntMap.Strict as IntMap import Data.Map (Map) @@ -59,7 +67,7 @@ import Data.Typeable (Typeable) import GHC.Generics (Generic) import Ouroboros.Network.Block -import Ouroboros.Network.Chain (Chain, toOldestFirst) +import Ouroboros.Network.Chain (Chain, genesisPoint, toOldestFirst) import Ouroboros.Consensus.Crypto.Hash.Class import Ouroboros.Consensus.Crypto.Hash.MD5 (MD5) @@ -77,10 +85,10 @@ import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.HList (All, HList) import qualified Ouroboros.Consensus.Util.HList as HList +import qualified Ouroboros.Consensus.Util.SlotBounded as SB {------------------------------------------------------------------------------- Basic definitions - -------------------------------------------------------------------------------} data Tx = Tx (Set TxIn) [TxOut] @@ -316,29 +324,30 @@ instance (Typeable p, SimpleBlockCrypto c) => StandardHash (SimpleBlock p c) Creating blocks -------------------------------------------------------------------------------} -forgeBlock :: forall m p c. - ( HasNodeState p m - , MonadRandom m - , OuroborosTag p - , SimpleBlockCrypto c - , Serialise (Payload p (SimplePreHeader p c)) - ) - => NodeConfig p - -> SlotNo -- ^ Current slot - -> BlockNo -- ^ Current block number - -> ChainHash (SimpleHeader p c) -- ^ Previous hash - -> [Tx] -- ^ Txs to add in the block - -> IsLeader p - -> m (SimpleBlock p c) -forgeBlock cfg curSlot curNo prevHash txs proof = do - ouroborosPayload <- mkPayload encode cfg proof preHeader +forgeSimpleBlock :: forall m p c. + ( HasNodeState p m + , MonadRandom m + , OuroborosTag p + , SimpleBlockCrypto c + , Serialise (Payload p (SimplePreHeader p c)) + , SupportedBlock p (SimpleBlock p c) + ) + => NodeConfig p + -> SlotNo -- ^ Current slot + -> BlockNo -- ^ Current block number + -> ChainHash (SimpleHeader p c) -- ^ Previous hash + -> [GenTx (SimpleBlock p c)] -- ^ Txs to add in the block + -> IsLeader p + -> m (SimpleBlock p c) +forgeSimpleBlock cfg curSlot curNo prevHash txs proof = do + ouroborosPayload <- mkPayload (Proxy @(SimpleBlock p c)) cfg proof preHeader return $ SimpleBlock { simpleHeader = mkSimpleHeader preHeader ouroborosPayload , simpleBody = body } where body :: SimpleBody - body = SimpleBody txs + body = SimpleBody (map simpleGenTx txs) -- We use the size of the body, not of the whole block (= header + body), -- since the header size is fixed and this size is only used for @@ -368,12 +377,26 @@ type instance BlockProtocol (SimpleBlock p c) = p type instance BlockProtocol (SimpleHeader p c) = p +instance (SimpleBlockCrypto c, OuroborosTag p, Serialise (Payload p (SimplePreHeader p c))) + => HasPreHeader (SimpleHeader p c) where + type PreHeader (SimpleHeader p c) = SimplePreHeader p c + + blockPreHeader = headerPreHeader + encodePreHeader = const encode instance (SimpleBlockCrypto c, OuroborosTag p, Serialise (Payload p (SimplePreHeader p c))) => HasPreHeader (SimpleBlock p c) where type PreHeader (SimpleBlock p c) = SimplePreHeader p c - blockPreHeader = headerPreHeader . simpleHeader + blockPreHeader = headerPreHeader . simpleHeader + encodePreHeader = const encode + +instance ( SimpleBlockCrypto c + , OuroborosTag p + , Serialise (Payload p (SimplePreHeader p c)) + ) + => HasPayload p (SimpleHeader p c) where + blockPayload _ = headerOuroboros instance ( SimpleBlockCrypto c , OuroborosTag p @@ -382,6 +405,15 @@ instance ( SimpleBlockCrypto c => HasPayload p (SimpleBlock p c) where blockPayload _ = headerOuroboros . simpleHeader +-- TODO: This instance is ugly.. can we avoid it? +instance ( OuroborosTag p + , SimpleBlockCrypto c + , Serialise (Payload p (SimplePreHeader (ExtNodeConfig cfg p) c)) + , Typeable cfg + ) + => HasPayload p (SimpleHeader (ExtNodeConfig cfg p) c) where + blockPayload _ = encPayloadP . headerOuroboros + -- TODO: This instance is ugly.. can we avoid it? instance ( OuroborosTag p , SimpleBlockCrypto c @@ -391,27 +423,33 @@ instance ( OuroborosTag p => HasPayload p (SimpleBlock (ExtNodeConfig cfg p) c) where blockPayload _ = encPayloadP . headerOuroboros . simpleHeader -instance OuroborosTag p => UpdateLedger (SimpleBlock p c) where +instance ( OuroborosTag p + , SimpleBlockCrypto c + , Serialise (Payload p (SimplePreHeader p c)) + ) => UpdateLedger (SimpleBlock p c) where data LedgerState (SimpleBlock p c) = SimpleLedgerState { slsUtxo :: Utxo , slsConfirmed :: Set (Hash ShortHash Tx) + , slsTip :: Point (SimpleBlock p c) } data LedgerError (SimpleBlock p c) = LedgerErrorInvalidInputs InvalidInputs deriving (Show) + data LedgerConfig (SimpleBlock p c) = MockLedgerConfig - -- | For the mock implementation, we don't need any state for header - -- validation at all, after all, we validate blocks /anyway/. The only thing - -- we do need to know is that the hash in the 'Point' matches the block. - data HeaderState (SimpleBlock p c) = SimpleHeaderState + applyLedgerHeader _ _ = pure + applyLedgerBlock _ = \blk -> fmap (updateTip blk) + . updateSimpleLedgerState blk + where + updateTip :: SimpleBlock p c + -> LedgerState (SimpleBlock p c) + -> LedgerState (SimpleBlock p c) + updateTip b st = st { slsTip = blockPoint b } - -- Apply a block to the ledger state - applyLedgerState = updateSimpleLedgerState - getHeaderState _ _ = SimpleHeaderState - advanceHeader _ _ _ = return SimpleHeaderState + ledgerTipPoint = slsTip -deriving instance OuroborosTag p => Show (LedgerState (SimpleBlock p c)) +deriving instance (OuroborosTag p, SimpleBlockCrypto c) => Show (LedgerState (SimpleBlock p c)) updateSimpleLedgerState :: (Monad m, HasUtxo a) => a @@ -419,24 +457,40 @@ updateSimpleLedgerState :: (Monad m, HasUtxo a) -> ExceptT (LedgerError (SimpleBlock p c)) m (LedgerState (SimpleBlock p c)) -updateSimpleLedgerState b (SimpleLedgerState u c) = do +updateSimpleLedgerState b (SimpleLedgerState u c t) = do u' <- withExceptT LedgerErrorInvalidInputs $ updateUtxo b u - return $ SimpleLedgerState u' (c `Set.union` confirmed b) + return $ SimpleLedgerState u' (c `Set.union` confirmed b) t + +instance ( OuroborosTag p + , SimpleBlockCrypto c + , Serialise (Payload p (SimplePreHeader p c)) + ) => LedgerConfigView (SimpleBlock p c) where + ledgerConfigView = const MockLedgerConfig {------------------------------------------------------------------------------- Applying transactions -------------------------------------------------------------------------------} -instance OuroborosTag p => ApplyTx (SimpleBlock p c) where - type GenTx (SimpleBlock p c) = Tx +instance ( OuroborosTag p + , SimpleBlockCrypto c + , Serialise (Payload p (SimplePreHeader p c)) + ) => ApplyTx (SimpleBlock p c) where + newtype GenTx (SimpleBlock p c) = SimpleGenTx { simpleGenTx :: Tx } + type ApplyTxErr (SimpleBlock p c) = LedgerError (SimpleBlock p c) - applyTx = updateSimpleLedgerState - reapplyTx = updateSimpleLedgerState - reapplyTxSameState = (mustSucceed . runExcept) .: updateSimpleLedgerState + applyTx = \_ -> updateSimpleLedgerState + reapplyTx = \_ -> updateSimpleLedgerState + reapplyTxSameState = \_ -> (mustSucceed . runExcept) .: updateSimpleLedgerState where mustSucceed (Left _) = error "reapplyTxSameState: unexpected error" mustSucceed (Right st) = st +instance HasUtxo (GenTx (SimpleBlock p c)) where + txIns = txIns . simpleGenTx + txOuts = txOuts . simpleGenTx + confirmed = confirmed . simpleGenTx + updateUtxo = updateUtxo . simpleGenTx + {------------------------------------------------------------------------------- Support for various consensus algorithms -------------------------------------------------------------------------------} @@ -449,13 +503,30 @@ type AddrDist = Map Addr NodeId instance (BftCrypto c, SimpleBlockCrypto c') => ProtocolLedgerView (SimpleBlock (Bft c) c') where protocolLedgerView _ _ = () + anachronisticProtocolLedgerView _ _ _ = Just $ SB.unbounded () + +instance (SimpleBlockCrypto c') + => BlockSupportsPBft PBftMockCrypto (SimpleBlock (ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PBftMockCrypto)) c') + +instance (SimpleBlockCrypto c') + => BlockSupportsPBft PBftMockCrypto (SimpleHeader (ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PBftMockCrypto)) c') -- | Mock ledger is capable of running PBFT, but we simply assume the delegation -- map and the protocol parameters can be found statically in the node -- configuration. -instance (PBftCrypto c, SimpleBlockCrypto c') - => ProtocolLedgerView (SimpleBlock (ExtNodeConfig (PBftLedgerView c) (PBft c)) c') where +instance (SimpleBlockCrypto c') + => ProtocolLedgerView (SimpleBlock (ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PBftMockCrypto)) c') where protocolLedgerView (EncNodeConfig _ pbftParams) _ls = pbftParams + -- This instance is correct, because the delegation map doesn't change in the + -- node configuration. + anachronisticProtocolLedgerView (EncNodeConfig _ pbftParams) _ _ + = Just $ SB.unbounded pbftParams + +instance (PraosCrypto c, SimpleBlockCrypto c') + => (BlockSupportsPraos c (SimpleBlock (ExtNodeConfig AddrDist (Praos c)) c')) + +instance (PraosCrypto c, SimpleBlockCrypto c') + => (BlockSupportsPraos c (SimpleHeader (ExtNodeConfig AddrDist (Praos c)) c')) -- | Praos needs a ledger that can give it the "active stake distribution" -- @@ -469,19 +540,23 @@ instance ( PraosCrypto c, SimpleBlockCrypto c') => ProtocolLedgerView (SimpleBlock (ExtNodeConfig AddrDist (Praos c)) c') where protocolLedgerView (EncNodeConfig _ addrDist) _ = equalStakeDistr addrDist - where - equalStakeDistr :: AddrDist -> StakeDist - equalStakeDistr = IntMap.fromList - . mapMaybe (nodeStake . snd) - . Map.toList - nodeStake :: NodeId -> Maybe (Int, Rational) - nodeStake (RelayId _) = Nothing - nodeStake (CoreId i) = Just (i, 1) + anachronisticProtocolLedgerView (EncNodeConfig _ addrDist) _ _ = + Just $ SB.unbounded $ equalStakeDistr addrDist + +nodeStake :: NodeId -> Maybe (Int, Rational) +nodeStake (RelayId _) = Nothing +nodeStake (CoreId i) = Just (i, 1) + +equalStakeDistr :: AddrDist -> StakeDist +equalStakeDistr = IntMap.fromList + . mapMaybe (nodeStake . snd) + . Map.toList instance (PraosCrypto c, SimpleBlockCrypto c') => ProtocolLedgerView (SimpleBlock (WithLeaderSchedule (Praos c)) c') where protocolLedgerView _ _ = () + anachronisticProtocolLedgerView _ _ _ = Just $ SB.unbounded () {------------------------------------------------------------------------------- Compute relative stake @@ -514,6 +589,38 @@ totalStakes addrDist = foldl f Map.empty Just (CoreId nid) -> Map.insertWith (+) (StakeCore nid) stake m _ -> Map.insertWith (+) StakeEverybodyElse stake m +{------------------------------------------------------------------------------- + Compute protocol parameters +-------------------------------------------------------------------------------} + +-- | Construct address to node ID mapping +mkAddrDist :: Int -- ^ Number of nodes + -> AddrDist +mkAddrDist numCoreNodes = + Map.fromList $ zip [[addr] | addr <- ['a'..]] + [CoreId n | n <- [0 .. numCoreNodes - 1]] + +-- | Transaction giving initial stake to the nodes +genesisTx :: AddrDist -> Tx +genesisTx addrDist = Tx mempty [(addr, 1000) | addr <- Map.keys addrDist] + +genesisUtxo :: AddrDist -> Utxo +genesisUtxo addrDist = + fromRight (error "genesisLedger: invalid genesis tx") $ + runExcept (utxo (genesisTx addrDist)) + +genesisLedgerState :: AddrDist -> LedgerState (SimpleBlock p c) +genesisLedgerState addrDist = SimpleLedgerState { + slsUtxo = genesisUtxo addrDist + , slsConfirmed = Set.singleton (hash (genesisTx addrDist)) + , slsTip = genesisPoint + } + +-- | Genesis stake distribution +genesisStakeDist :: AddrDist -> StakeDist +genesisStakeDist addrDist = + relativeStakes (totalStakes addrDist (genesisUtxo addrDist)) + {------------------------------------------------------------------------------- Serialisation -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs index 0f83639b292..6583b87fb2f 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs @@ -7,6 +7,7 @@ module Ouroboros.Consensus.Mempool.API ( import Control.Monad.Except import Data.Sequence (Seq) +import GHC.Stack (HasCallStack) import Control.Monad.Class.MonadSTM @@ -18,28 +19,39 @@ class UpdateLedger b => ApplyTx b where -- The mempool (and, accordingly, blocks) consist of "generalized -- transactions"; this could be "proper" transactions (transferring funds) but -- also other kinds of things such as update proposals, delegations, etc. - type family GenTx b :: * + data family GenTx b :: * + + -- | Updating the ledger with a single transaction may result in a different + -- error type as when updating it with a block + type family ApplyTxErr b :: * -- | Apply transaction we have not previously seen before - applyTx :: GenTx b + applyTx :: LedgerConfig b + -> GenTx b -> LedgerState b - -> Except (LedgerError b) (LedgerState b) + -> Except (ApplyTxErr b) (LedgerState b) -- | Re-apply a transaction -- -- When we re-apply a transaction to a potentially different ledger state -- expensive checks such as cryptographic hashes can be skipped, but other -- checks (such as checking for double spending) must still be done. - reapplyTx :: GenTx b + reapplyTx :: HasCallStack + => LedgerConfig b + -> GenTx b -> LedgerState b - -> Except (LedgerError b) (LedgerState b) + -> Except (ApplyTxErr b) (LedgerState b) -- | Re-apply a transaction to the very same state it was applied in before -- -- In this case no error can occur. -- -- See also 'ldbConfReapply' for comments on implementing this function. - reapplyTxSameState :: GenTx b -> LedgerState b -> LedgerState b + reapplyTxSameState :: HasCallStack + => LedgerConfig b + -> GenTx b + -> LedgerState b + -> LedgerState b -- | Mempool -- @@ -85,7 +97,7 @@ data Mempool m blk = Mempool { -- they have already been included. (Distinguishing between these two -- cases can be done in theory, but it is expensive unless we have an -- index of transaction hashes that have been included on the blockchain.) - addTxs :: [GenTx blk] -> m [(GenTx blk, LedgerError blk)] + addTxs :: [GenTx blk] -> m [(GenTx blk, ApplyTxErr blk)] -- | Get all transactions in the mempool (oldest to newest) -- diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/Impl.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/Impl.hs index d776c1a39b1..f058da40624 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/Impl.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/Impl.hs @@ -27,9 +27,11 @@ import Ouroboros.Consensus.Util (repeatedly) -------------------------------------------------------------------------------} openMempool :: (MonadSTM m, StandardHash blk, ApplyTx blk) - => ChainDB m blk hdr -> m (Mempool m blk) -openMempool chainDB = do - env <- initMempoolEnv chainDB + => ChainDB m blk hdr + -> LedgerConfig blk + -> m (Mempool m blk) +openMempool chainDB cfg = do + env <- initMempoolEnv chainDB cfg return Mempool { addTxs = implAddTxs env , getTxs = implGetTxs env @@ -49,17 +51,21 @@ data InternalState blk = IS { } data MempoolEnv m blk hdr = MempoolEnv { - mpEnvChainDB :: ChainDB m blk hdr - , mpEnvStateVar :: TVar m (InternalState blk) + mpEnvChainDB :: ChainDB m blk hdr + , mpEnvLedgerCfg :: LedgerConfig blk + , mpEnvStateVar :: TVar m (InternalState blk) } initInternalState :: InternalState blk initInternalState = IS Seq.empty Block.GenesisHash -initMempoolEnv :: MonadSTM m => ChainDB m blk hdr -> m (MempoolEnv m blk hdr) -initMempoolEnv chainDB = do +initMempoolEnv :: MonadSTM m + => ChainDB m blk hdr + -> LedgerConfig blk + -> m (MempoolEnv m blk hdr) +initMempoolEnv chainDB cfg = do isVar <- atomically $ newTVar initInternalState - return $ MempoolEnv chainDB isVar + return $ MempoolEnv chainDB cfg isVar {------------------------------------------------------------------------------- Implementation @@ -69,7 +75,7 @@ initMempoolEnv chainDB = do implAddTxs :: forall m blk hdr. (MonadSTM m, StandardHash blk, ApplyTx blk) => MempoolEnv m blk hdr -> [GenTx blk] - -> m [(GenTx blk, LedgerError blk)] + -> m [(GenTx blk, ApplyTxErr blk)] implAddTxs mpEnv@MempoolEnv{..} txs = atomically $ do ValidationResult{..} <- validateNew <$> validateIS mpEnv writeTVar mpEnvStateVar IS { isTxs = vrValid @@ -78,7 +84,7 @@ implAddTxs mpEnv@MempoolEnv{..} txs = atomically $ do return vrInvalid where validateNew :: ValidationResult blk -> ValidationResult blk - validateNew = extendsVR False txs + validateNew = extendsVR mpEnvLedgerCfg False txs implGetTxs :: (MonadSTM m, StandardHash blk, ApplyTx blk) => MempoolEnv m blk hdr @@ -111,16 +117,17 @@ data ValidationResult blk = ValidationResult { -- | The transactions that were invalid, along with their errors -- -- Order not guaranteed - , vrInvalid :: [(GenTx blk, LedgerError blk)] + , vrInvalid :: [(GenTx blk, ApplyTxErr blk)] } -- | Initialize 'ValidationResult' from a ledger state and a list of -- transactions /known/ to be valid in that ledger state initVR :: forall blk. ApplyTx blk - => Seq (GenTx blk) + => LedgerConfig blk + -> Seq (GenTx blk) -> (ChainHash blk, LedgerState blk) -> ValidationResult blk -initVR = \knownValid (tip, st) -> ValidationResult { +initVR cfg = \knownValid (tip, st) -> ValidationResult { vrBefore = tip , vrValid = knownValid , vrAfter = afterKnownValid (Foldable.toList knownValid) st @@ -129,7 +136,7 @@ initVR = \knownValid (tip, st) -> ValidationResult { where afterKnownValid :: [GenTx blk] -> LedgerState blk -> LedgerState blk afterKnownValid [] = id - afterKnownValid (tx:txs) = afterKnownValid txs . reapplyTxSameState tx + afterKnownValid (tx:txs) = afterKnownValid txs . reapplyTxSameState cfg tx -- | Extend 'ValidationResult' with a transaction that may or may not be -- valid in this ledger state @@ -139,12 +146,13 @@ initVR = \knownValid (tip, st) -> ValidationResult { -- validated this transaction, because if we have, we can skip things like -- cryptographic signatures. extendVR :: ApplyTx blk - => Bool -- ^ Was these transactions previously validated? + => LedgerConfig blk + -> Bool -- ^ Was these transactions previously validated? -> GenTx blk -> ValidationResult blk -> ValidationResult blk -extendVR prevApplied tx ValidationResult{..} = - case runExcept $ (if prevApplied then reapplyTx else applyTx) tx vrAfter of +extendVR cfg prevApplied tx ValidationResult{..} = + case runExcept $ (if prevApplied then reapplyTx else applyTx) cfg tx vrAfter of Left err -> ValidationResult { vrBefore = vrBefore , vrValid = vrValid @@ -160,11 +168,12 @@ extendVR prevApplied tx ValidationResult{..} = -- | Apply 'extendVR' to a list of transactions, in order extendsVR :: ApplyTx blk - => Bool -- ^ Were these transactions previously applied? + => LedgerConfig blk + -> Bool -- ^ Were these transactions previously applied? -> [GenTx blk] -> ValidationResult blk -> ValidationResult blk -extendsVR prevApplied = repeatedly (extendVR prevApplied) +extendsVR cfg prevApplied = repeatedly (extendVR cfg prevApplied) -- | Validate internal state validateIS :: forall m blk hdr. (MonadSTM m, StandardHash blk, ApplyTx blk) @@ -179,6 +188,6 @@ validateIS MempoolEnv{..} = -> InternalState blk -> ValidationResult blk go tip st IS{..} - | tip == isTip = initVR isTxs (tip, st) - | otherwise = extendsVR True (Foldable.toList isTxs) $ - initVR Seq.empty (tip, st) + | tip == isTip = initVR mpEnvLedgerCfg isTxs (tip, st) + | otherwise = extendsVR mpEnvLedgerCfg True (Foldable.toList isTxs) $ + initVR mpEnvLedgerCfg Seq.empty (tip, st) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs index 2cbdbf9a35f..8435a8f9d9f 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs @@ -32,6 +32,7 @@ import Codec.Serialise (Serialise) import Control.Monad (void) import Crypto.Random (ChaChaDRG) import qualified Data.Foldable as Foldable +import Data.Functor.Contravariant (contramap) import Data.Map.Strict (Map) import Data.Void (Void) @@ -50,6 +51,8 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment (..), headSlot) import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch +import Ouroboros.Network.BlockFetch.Client (BlockFetchClient, + blockFetchClient) import Ouroboros.Network.BlockFetch.State (FetchMode (..)) import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Network.Protocol.BlockFetch.Server @@ -60,7 +63,6 @@ import Ouroboros.Network.Protocol.ChainSync.Server import Ouroboros.Network.Protocol.ChainSync.Type import Ouroboros.Consensus.BlockchainTime -import Ouroboros.Consensus.BlockFetchClient import Ouroboros.Consensus.BlockFetchServer import Ouroboros.Consensus.ChainSyncClient import Ouroboros.Consensus.ChainSyncServer @@ -111,6 +113,9 @@ data NodeKernel m up blk hdr = NodeKernel { -- | The node's mempool , getMempool :: Mempool m blk + -- | The node's static configuration + , getNodeConfig :: NodeConfig (BlockProtocol blk) + -- | Notify network layer of new upstream node -- -- NOTE: Eventually it will be the responsibility of the network layer @@ -187,8 +192,10 @@ nodeKernel , MonadTime m , MonadThrow (STM m) , ProtocolLedgerView blk + , LedgerConfigView blk , HasHeader hdr , HeaderHash hdr ~ HeaderHash blk + , SupportedBlock (BlockProtocol hdr) hdr , BlockProtocol hdr ~ BlockProtocol blk , Ord up , TraceConstraints up blk hdr @@ -196,7 +203,7 @@ nodeKernel ) => NodeParams m up blk hdr -> m (NodeKernel m up blk hdr) -nodeKernel params@NodeParams { threadRegistry } = do +nodeKernel params@NodeParams { threadRegistry, cfg } = do st <- initInternalState params forkBlockProduction st @@ -214,6 +221,7 @@ nodeKernel params@NodeParams { threadRegistry } = do return NodeKernel { getChainDB = chainDB , getMempool = mempool + , getNodeConfig = cfg , addUpstream = npAddUpstream (networkLayer st) , addDownstream = npAddDownstream (networkLayer st) } @@ -235,7 +243,7 @@ data InternalState m up blk hdr = IS { , chainDB :: ChainDB m blk hdr , blockFetchInterface :: BlockFetchConsensusInterface up hdr blk m , fetchClientRegistry :: FetchClientRegistry up hdr blk m - , varCandidates :: TVar m (Map up (TVar m (CandidateState blk hdr))) + , varCandidates :: TVar m (Map up (TVar m (CandidateState hdr))) , varState :: TVar m (NodeState (BlockProtocol blk)) , tracer :: Tracer m String , mempool :: Mempool m blk @@ -251,6 +259,8 @@ initInternalState , HasHeader hdr , HeaderHash hdr ~ HeaderHash blk , ProtocolLedgerView blk + , LedgerConfigView blk + , SupportedBlock (BlockProtocol hdr) hdr , BlockProtocol hdr ~ BlockProtocol blk , Ord up , TraceConstraints up blk hdr @@ -261,7 +271,7 @@ initInternalState initInternalState NodeParams {..} = do varCandidates <- atomically $ newTVar mempty varState <- atomically $ newTVar initState - mempool <- openMempool chainDB + mempool <- openMempool chainDB (ledgerConfigView cfg) fetchClientRegistry <- newFetchClientRegistry diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs index f69bd23207c..08dc4492c90 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs @@ -53,6 +53,8 @@ import Ouroboros.Network.Chain (Chain) import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF import Ouroboros.Consensus.Util.Random +import GHC.Stack + -- | The (open) universe of Ouroboros protocols -- -- This class encodes the part that is independent from any particular @@ -139,12 +141,12 @@ class ( Show (ChainState p) -- | Construct the ouroboros-specific payload of a block -- -- Gets the proof that we are the leader and the preheader as arguments. - mkPayload :: (HasNodeState p m, MonadRandom m) - => (ph -> Encoding) + mkPayload :: (SupportedBlock p b, HasNodeState p m, MonadRandom m) + => proxy b -> NodeConfig p -> IsLeader p - -> ph - -> m (Payload p ph) + -> PreHeader b + -> m (Payload p (PreHeader b)) -- | Do we prefer the candidate chain over ours? -- @@ -185,9 +187,10 @@ class ( Show (ChainState p) -> m (Maybe (IsLeader p)) -- | Apply a block - applyChainState :: SupportedBlock p b - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig p + -- + -- TODO this will only be used with headers + applyChainState :: (SupportedBlock p b, HasCallStack) + => NodeConfig p -> LedgerView p -- /Updated/ ledger state -> b -> ChainState p -- /Previous/ Ouroboros state @@ -196,6 +199,33 @@ class ( Show (ChainState p) -- | We require that protocols support a @k@ security parameter protocolSecurityParam :: NodeConfig p -> SecurityParam + -- | We require that it's possible to reverse the chain state up to @k@ + -- blocks. + -- + -- This function should attempt to rewind the chain state to the state at some + -- given slot. + -- + -- Implementers should take care that this function accurately reflects the + -- slot number, rather than the number of blocks, since naively the + -- 'ChainState' will be updated only on processing an actual block. + -- + -- Rewinding the chain state is intended to be used when switching to a + -- fork, longer or equally long to the chain to which the current chain + -- state corresponds. So each rewinding should be followed by rolling + -- forward (using 'applyChainState') at least as many blocks that we have + -- rewound. + -- + -- Note that repeatedly rewinding a chain state does not make it possible to + -- rewind it all the way to genesis (this would mean that the whole + -- historical chain state is accumulated or derivable from the current chain + -- state). For example, rewinding a chain state by @i@ blocks and then + -- rewinding that chain state again by @j@ where @i + j > k@ is not possible + -- and will yield 'Nothing'. + rewindChainState :: NodeConfig p + -> ChainState p + -> SlotNo -- ^ Slot to rewind to. + -> Maybe (ChainState p) + -- | Protocol security parameter -- -- We interpret this as the number of rollbacks we support. @@ -211,7 +241,8 @@ newtype SecurityParam = SecurityParam { maxRollbacks :: Word64 } -- | Extract the pre-header from a block class (HasHeader b) => HasPreHeader b where type family PreHeader b :: * - blockPreHeader :: b -> PreHeader b + blockPreHeader :: b -> PreHeader b + encodePreHeader :: proxy b -> PreHeader b -> Encoding -- | Blocks that contain the ouroboros payload -- diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs index 0eb67bb3f6c..db7c746e9e4 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs @@ -23,6 +23,7 @@ module Ouroboros.Consensus.Protocol.BFT ( import Codec.Serialise (Serialise (..)) import Control.Monad.Except +import Data.Functor.Identity import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Typeable (Typeable) @@ -37,6 +38,7 @@ import Ouroboros.Consensus.Crypto.DSIGN.Mock (MockDSIGN) import Ouroboros.Consensus.Node (NodeId (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Test +import Ouroboros.Consensus.Util (Empty) import Ouroboros.Consensus.Util.Condense {------------------------------------------------------------------------------- @@ -65,7 +67,7 @@ data BftParams = BftParams { , bftNumNodes :: Word64 } -instance BftCrypto c => OuroborosTag (Bft c) where +instance (BftCrypto c) => OuroborosTag (Bft c) where -- | The BFT payload is just the signature newtype Payload (Bft c) ph = BftPayload { bftSignature :: SignedDSIGN (BftDSIGN c) ph @@ -89,8 +91,8 @@ instance BftCrypto c => OuroborosTag (Bft c) where protocolSecurityParam = bftSecurityParam . bftParams - mkPayload toEnc BftNodeConfig{..} _proof preheader = do - signature <- signedDSIGN toEnc preheader bftSignKey + mkPayload proxy BftNodeConfig{..} _proof preheader = do + signature <- signedDSIGN (encodePreHeader proxy) preheader bftSignKey return $ BftPayload { bftSignature = signature } @@ -104,18 +106,22 @@ instance BftCrypto c => OuroborosTag (Bft c) where where BftParams{..} = bftParams - applyChainState toEnc cfg@BftNodeConfig{..} _l b _cs = do + applyChainState cfg@BftNodeConfig{..} _l b _cs = do -- TODO: Should deal with unknown node IDs - if verifySignedDSIGN toEnc (bftVerKeys Map.! expectedLeader) - (blockPreHeader b) - (bftSignature (blockPayload cfg b)) - then return () - else throwError BftInvalidSignature + let proxy = Identity b + case verifySignedDSIGN + (encodePreHeader proxy) + (bftVerKeys Map.! expectedLeader) + (blockPreHeader b) + (bftSignature (blockPayload cfg b)) of + Right () -> return () + Left err -> throwError $ BftInvalidSignature err where BftParams{..} = bftParams SlotNo n = blockSlot b expectedLeader = CoreId $ fromIntegral (n `mod` bftNumNodes) + rewindChainState _ _ _ = Just () deriving instance BftCrypto c => Show (Payload (Bft c) ph) deriving instance BftCrypto c => Eq (Payload (Bft c) ph) @@ -130,15 +136,19 @@ instance (DSIGNAlgorithm (BftDSIGN c)) => Serialise (Payload (Bft c) ph) where BFT specific types -------------------------------------------------------------------------------} -data BftValidationErr = BftInvalidSignature +data BftValidationErr = BftInvalidSignature String deriving (Show) {------------------------------------------------------------------------------- Crypto models -------------------------------------------------------------------------------} + +-- The equality constraint here is slightly weird; we need it to force GHC to +-- partially apply this constraint in `OuroborosTag` and thus conclude that it +-- can satisfy it universally. -- | Crypto primitives required by BFT -class (Typeable c, DSIGNAlgorithm (BftDSIGN c)) => BftCrypto c where +class (Typeable c, DSIGNAlgorithm (BftDSIGN c), Signable (BftDSIGN c) ~ Empty) => BftCrypto c where type family BftDSIGN c :: * data BftStandardCrypto diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs index f8e0fa47954..bbf0aec0162 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs @@ -57,13 +57,14 @@ instance (Typeable cfg, OuroborosTag p) => OuroborosTag (ExtNodeConfig cfg p) wh -- Propagate changes -- - mkPayload toEnc (EncNodeConfig cfg _) proof ph = - EncPayload <$> mkPayload toEnc cfg proof ph + mkPayload proxy (EncNodeConfig cfg _) proof ph = + EncPayload <$> mkPayload proxy cfg proof ph preferCandidate (EncNodeConfig cfg _) = preferCandidate cfg compareCandidates (EncNodeConfig cfg _) = compareCandidates cfg checkIsLeader (EncNodeConfig cfg _) = checkIsLeader cfg - applyChainState toEnc (EncNodeConfig cfg _) = applyChainState toEnc cfg + applyChainState (EncNodeConfig cfg _) = applyChainState cfg + rewindChainState (EncNodeConfig cfg _) = rewindChainState cfg protocolSecurityParam (EncNodeConfig cfg _) = protocolSecurityParam cfg deriving instance Eq (Payload p ph) => Eq (Payload (ExtNodeConfig cfg p) ph) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs index bec70b5f08f..bb9f9263a52 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs @@ -70,7 +70,8 @@ instance OuroborosTag p => OuroborosTag (WithLeaderSchedule p) where | lsNodeConfigNodeId `elem` nids -> Just () | otherwise -> Nothing - applyChainState _ _ _ _ _ = return () + applyChainState _ _ _ _ = return () + rewindChainState _ _ _ = Just () deriving instance Eq (Payload (WithLeaderSchedule p) ph) deriving instance Ord (Payload (WithLeaderSchedule p) ph) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs index 129c00c87dd..a9ac313732d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs @@ -61,10 +61,11 @@ instance (Typeable p, Typeable s, ChainSelection p s) => OuroborosTag (ModChainS type ValidationErr (ModChainSel p s) = ValidationErr p type SupportedBlock (ModChainSel p s) = SupportedBlock p - mkPayload toEnc (McsNodeConfig cfg) proof ph = McsPayload <$> mkPayload toEnc cfg proof ph + mkPayload proxy (McsNodeConfig cfg) proof ph = McsPayload <$> mkPayload proxy cfg proof ph checkIsLeader (McsNodeConfig cfg) = checkIsLeader cfg - applyChainState toEnc (McsNodeConfig cfg) = applyChainState toEnc cfg + applyChainState (McsNodeConfig cfg) = applyChainState cfg + rewindChainState (McsNodeConfig cfg) = rewindChainState cfg protocolSecurityParam (McsNodeConfig cfg) = protocolSecurityParam cfg preferCandidate (McsNodeConfig cfg) = preferCandidate' (Proxy :: Proxy s) cfg diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index 8ef8e5ee59a..298a168ebf8 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} module Ouroboros.Consensus.Protocol.PBFT ( PBft @@ -16,8 +15,9 @@ module Ouroboros.Consensus.Protocol.PBFT ( , PBftParams(..) -- * Classes , PBftCrypto(..) - , PBftStandardCrypto , PBftMockCrypto + , PBftCardanoCrypto + , BlockSupportsPBft -- * Type instances , NodeConfig(..) , Payload(..) @@ -27,48 +27,35 @@ import Codec.Serialise (Serialise (..)) import qualified Codec.Serialise.Decoding as Dec import qualified Codec.Serialise.Encoding as Enc import Control.Monad.Except -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import Data.Functor.Identity +import Data.Reflection (Given (..)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq -import Data.Tuple (swap) import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics (Generic) +import qualified Cardano.Chain.Common as CC.Common +import Cardano.Crypto (ProtocolMagicId) + import Ouroboros.Network.Block +import Ouroboros.Consensus.Crypto.DSIGN.Cardano import Ouroboros.Consensus.Crypto.DSIGN.Class -import Ouroboros.Consensus.Crypto.DSIGN.Ed448 (Ed448DSIGN) import Ouroboros.Consensus.Crypto.DSIGN.Mock (MockDSIGN) import Ouroboros.Consensus.Node (NodeId (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Test import Ouroboros.Consensus.Util.Condense --- | Invert a map which we assert to be a bijection. --- If this map is not a bijection, the behaviour is not guaranteed. --- --- Examples: --- --- >>> invertBijection (Map.fromList [('a', 1 :: Int), ('b', 2), ('c', 3)]) --- fromList [(1,'a'),(2,'b'),(3,'c')] -invertBijection - :: Ord v - => Map k v - -> Map v k -invertBijection - = Map.fromListWith const - . fmap swap - . Map.toList - -data PBftLedgerView c = PBftLedgerView - -- TODO Once we have the window and threshold in the protocol parameters, we - -- will use them here and remove the parameters from 'PBftParams' below. - - -- ProtocolParameters Map from genesis to delegate keys. - -- Note that this map is injective by construction. - (Map (VerKeyDSIGN (PBftDSIGN c)) (VerKeyDSIGN (PBftDSIGN c))) +data PBftLedgerView c = PBftLedgerView { + -- | ProtocolParameters: map from genesis to delegate keys. + pbftDelegates :: Bimap (PBftVerKeyHash c) (PBftVerKeyHash c) + } + +deriving instance (Show (PBftVerKeyHash c)) => Show (PBftLedgerView c) {------------------------------------------------------------------------------- Protocol proper @@ -101,6 +88,10 @@ data PBftParams = PBftParams { , pbftSignatureThreshold :: Double } +class ( HasPayload (PBft c) b + , Signable (PBftDSIGN c) (PreHeader b) + ) => BlockSupportsPBft c b where + instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) where -- | The BFT payload is just the issuer and signature data Payload (PBft c) ph = PBftPayload { @@ -117,8 +108,8 @@ instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) where , pbftVerKey :: VerKeyDSIGN (PBftDSIGN c) } - type ValidationErr (PBft c) = PBftValidationErr - type SupportedBlock (PBft c) = HasPayload (PBft c) + type ValidationErr (PBft c) = PBftValidationErr c + type SupportedBlock (PBft c) = BlockSupportsPBft c type NodeState (PBft c) = () -- | We require two things from the ledger state: @@ -133,15 +124,12 @@ instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) where -- - a list of the last 'pbftSignatureWindow' signatures. -- - The last seen block slot type ChainState (PBft c) = - ( Seq (VerKeyDSIGN (PBftDSIGN c)) - -- Last seen block slot. - , SlotNo - ) + Seq (PBftVerKeyHash c, SlotNo) protocolSecurityParam = pbftSecurityParam . pbftParams - mkPayload toEnc PBftNodeConfig{..} _proof preheader = do - signature <- signedDSIGN toEnc preheader pbftSignKey + mkPayload proxy PBftNodeConfig{..} _proof preheader = do + signature <- signedDSIGN (encodePreHeader proxy) preheader pbftSignKey return $ PBftPayload { pbftIssuer = pbftVerKey , pbftSignature = signature @@ -156,31 +144,46 @@ instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) where where PBftParams{..} = pbftParams - applyChainState toEnc cfg@PBftNodeConfig{..} (PBftLedgerView dms) b (signers, lastSlot) = do + applyChainState cfg@PBftNodeConfig{..} lv@(PBftLedgerView dms) b chainState = do -- Check that the issuer signature verifies, and that it's a delegate of a -- genesis key, and that genesis key hasn't voted too many times. - - unless (verifySignedDSIGN toEnc (pbftIssuer payload) - (blockPreHeader b) - (pbftSignature payload)) - $ throwError PBftInvalidSignature + let proxy = Identity b + case verifySignedDSIGN + (encodePreHeader proxy) + (pbftIssuer payload) + (blockPreHeader b) + (pbftSignature payload) of + Right () -> return () + Left err -> throwError $ PBftInvalidSignature err + + let (signers, lastSlot) = ( takeR winSize $ fst <$> chainState + , maybe (SlotNo 0) snd $ Seq.lookup (Seq.length chainState) chainState + ) unless (blockSlot b > lastSlot) $ throwError PBftInvalidSlot - case Map.lookup (pbftIssuer payload) $ invertBijection dms of - Nothing -> throwError PBftNotGenesisDelegate + case Bimap.lookupR (hashVerKey $ pbftIssuer payload) dms of + Nothing -> throwError $ PBftNotGenesisDelegate (hashVerKey $ pbftIssuer payload) lv Just gk -> do when (Seq.length signers >= winSize - && Seq.length (Seq.filter (== gk) signers) >= wt) - $ throwError PBftExceededSignThreshold - let signers' = Seq.drop (Seq.length signers - winSize - 1) signers Seq.|> gk - return (signers', blockSlot b) + && Seq.length (Seq.filter (== gk) signers) > wt) + $ do throwError PBftExceededSignThreshold + return $! takeR (winSize + 2*k) chainState Seq.|> (gk, blockSlot b) where PBftParams{..} = pbftParams payload = blockPayload cfg b winSize = fromIntegral pbftSignatureWindow + SecurityParam (fromIntegral -> k) = pbftSecurityParam wt = floor $ pbftSignatureThreshold * fromIntegral winSize + -- Take the rightmost n elements of a sequence + takeR :: Integral i => i -> Seq a -> Seq a + takeR (fromIntegral -> n) s = Seq.drop (Seq.length s - n - 1) s + + rewindChainState _ cs slot = if slot == SlotNo 0 then Just Seq.empty else + case Seq.takeWhileL (\(_, s) -> s <= slot) cs of + _ Seq.:<| _ -> Just cs + _ -> Nothing deriving instance PBftCrypto c => Show (Payload (PBft c) ph) @@ -203,26 +206,48 @@ instance (DSIGNAlgorithm (PBftDSIGN c)) => Serialise (Payload (PBft c) ph) where BFT specific types -------------------------------------------------------------------------------} -data PBftValidationErr - = PBftInvalidSignature - | PBftNotGenesisDelegate +data PBftValidationErr c + = PBftInvalidSignature String + | PBftNotGenesisDelegate (PBftVerKeyHash c) (PBftLedgerView c) | PBftExceededSignThreshold | PBftInvalidSlot - deriving (Show) + +deriving instance (Show (PBftLedgerView c), PBftCrypto c) => Show (PBftValidationErr c) {------------------------------------------------------------------------------- Crypto models -------------------------------------------------------------------------------} -- | Crypto primitives required by BFT -class (Typeable c, DSIGNAlgorithm (PBftDSIGN c)) => PBftCrypto c where +class ( Typeable c + , DSIGNAlgorithm (PBftDSIGN c) + , Show (PBftVerKeyHash c) + , Ord (PBftVerKeyHash c) + , Eq (PBftVerKeyHash c) + , Show (PBftVerKeyHash c) + ) => PBftCrypto c where type family PBftDSIGN c :: * -data PBftStandardCrypto -data PBftMockCrypto + -- Cardano stores a map of stakeholder IDs rather than the verification key + -- directly. We make this family injective for convenience - whilst it's + -- _possible_ that there could be non-injective instances, the chances of there + -- being more than the two instances here are basically non-existent. + type family PBftVerKeyHash c = (d :: *) | d -> c + + hashVerKey :: VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c -instance PBftCrypto PBftStandardCrypto where - type PBftDSIGN PBftStandardCrypto = Ed448DSIGN +data PBftMockCrypto instance PBftCrypto PBftMockCrypto where - type PBftDSIGN PBftMockCrypto = MockDSIGN + type PBftDSIGN PBftMockCrypto = MockDSIGN + type PBftVerKeyHash PBftMockCrypto = VerKeyDSIGN MockDSIGN + + hashVerKey = id + +data PBftCardanoCrypto + +instance (Given ProtocolMagicId) => PBftCrypto PBftCardanoCrypto where + type PBftDSIGN PBftCardanoCrypto = CardanoDSIGN + type PBftVerKeyHash PBftCardanoCrypto = CC.Common.KeyHash + + hashVerKey (VerKeyCardanoDSIGN pk) = CC.Common.hashKey pk diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs index e6cbf5c577d..c6bbab516b1 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.Protocol.Praos ( StakeDist @@ -20,6 +21,7 @@ module Ouroboros.Consensus.Protocol.Praos ( , PraosCrypto(..) , PraosStandardCrypto , PraosMockCrypto + , BlockSupportsPraos -- * Type instances , NodeConfig(..) , Payload(..) @@ -31,6 +33,7 @@ import qualified Codec.Serialise.Decoding as Dec import qualified Codec.Serialise.Encoding as Enc import Control.Monad (unless) import Control.Monad.Except (throwError) +import Data.Functor.Identity import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.Proxy (Proxy (..)) @@ -55,6 +58,7 @@ import Ouroboros.Consensus.Crypto.VRF.Simple (SimpleVRF) import Ouroboros.Consensus.Node (CoreNodeId (..), NodeId (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Test +import Ouroboros.Consensus.Util (Empty) import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.HList (HList (..)) @@ -93,7 +97,7 @@ data PraosProof c = PraosProof { data PraosValidationError c = PraosInvalidSlot SlotNo SlotNo | PraosUnknownCoreId Int - | PraosInvalidSig (VerKeyKES (PraosKES c)) Natural (SigKES (PraosKES c)) + | PraosInvalidSig String (VerKeyKES (PraosKES c)) Natural (SigKES (PraosKES c)) | PraosInvalidCert (VerKeyVRF (PraosVRF c)) Encoding Natural (CertVRF (PraosVRF c)) | PraosInsufficientStake Double Natural @@ -127,6 +131,10 @@ data PraosParams = PraosParams { , praosLifetimeKES :: Natural } +class ( HasPayload (Praos c) b + , Signable (PraosKES c) (PreHeader b, PraosExtraFields c) + ) => BlockSupportsPraos c b where + instance (Serialise (PraosExtraFields c), PraosCrypto c) => OuroborosTag (Praos c) where data Payload (Praos c) ph = PraosPayload { @@ -150,10 +158,10 @@ instance (Serialise (PraosExtraFields c), PraosCrypto c) => OuroborosTag (Praos type LedgerView (Praos c) = StakeDist type IsLeader (Praos c) = PraosProof c type ValidationErr (Praos c) = PraosValidationError c - type SupportedBlock (Praos c) = HasPayload (Praos c) + type SupportedBlock (Praos c) = BlockSupportsPraos c type ChainState (Praos c) = [BlockInfo c] - mkPayload toEnc PraosNodeConfig{..} PraosProof{..} preheader = do + mkPayload proxy PraosNodeConfig{..} PraosProof{..} preheader = do keyKES <- getNodeState let extraFields = PraosExtraFields { praosCreator = praosLeader @@ -161,7 +169,7 @@ instance (Serialise (PraosExtraFields c), PraosCrypto c) => OuroborosTag (Praos , praosY = praosProofY } m <- signedKES - (\(a,b) -> encodeListLen 2 <> toEnc a <> encode b) + (\(a,b) -> encodeListLen 2 <> encodePreHeader proxy a <> encode b) (fromIntegral (unSlotNo praosProofSlot)) (preheader, extraFields) keyKES @@ -190,7 +198,7 @@ instance (Serialise (PraosExtraFields c), PraosCrypto c) => OuroborosTag (Praos } else Nothing - applyChainState toEnc cfg@PraosNodeConfig{..} sd b cs = do + applyChainState cfg@PraosNodeConfig{..} sd b cs = do let PraosPayload{..} = blockPayload cfg b ph = blockPreHeader b slot = blockSlot b @@ -208,13 +216,19 @@ instance (Serialise (PraosExtraFields c), PraosCrypto c) => OuroborosTag (Praos Just vks -> return vks -- verify block signature - unless (verifySignedKES - (\(x,y) -> encodeListLen 2 <> toEnc x <> encode y) - vkKES - (fromIntegral $ unSlotNo slot) - (ph, praosExtraFields) - praosSignature) $ - throwError $ PraosInvalidSig vkKES (fromIntegral $ unSlotNo slot) (getSig praosSignature) + let proxy = Identity b + case verifySignedKES + (\(x,y) -> encodeListLen 2 <> encodePreHeader proxy x <> encode y) + vkKES + (fromIntegral $ unSlotNo slot) + (ph, praosExtraFields) + praosSignature of + Right () -> return () + Left err -> throwError $ PraosInvalidSig + err + vkKES + (fromIntegral $ unSlotNo slot) + (getSig praosSignature) let (rho', y', t) = rhoYT cfg cs slot nid rho = praosRho praosExtraFields @@ -248,6 +262,21 @@ instance (Serialise (PraosExtraFields c), PraosCrypto c) => OuroborosTag (Praos return $ bi : cs + -- Rewind the chain state + -- + -- At the moment, this implementation of Praos keeps the full history of the + -- chain state since the dawn of time (#248). For this reason rewinding is + -- very simple, and we can't get to a point where we can't roll back more + -- (unless the slot number never occurred, but that would be a bug in the + -- caller). Once we limit the history we keep, this function will become + -- more complicated. + -- + -- We don't roll back to the exact slot since that slot might not have been + -- filled; instead we roll back the the block just before it. + rewindChainState PraosNodeConfig{..} cs rewindTo = + -- This may drop us back to the empty list if we go back to genesis + Just $ dropWhile (\bi -> biSlot bi > rewindTo) cs + -- NOTE: We redefine `preferCandidate` but NOT `compareCandidates` -- NOTE: See note regarding clock skew. preferCandidate PraosNodeConfig{..} ours cand = @@ -365,6 +394,8 @@ class ( KESAlgorithm (PraosKES c) , VRFAlgorithm (PraosVRF c) , HashAlgorithm (PraosHash c) , Typeable c + -- TODO: For now we insist that everything must be signable + , Signable (PraosKES c) ~ Empty ) => PraosCrypto (c :: *) where type family PraosKES c :: * type family PraosVRF c :: * diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs index 67344c0a2b3..14303864fae 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs @@ -56,13 +56,13 @@ instance OuroborosTag p => OuroborosTag (TestProtocol p) where -- The other types are unchanged -- - type NodeState (TestProtocol p) = NodeState p - type ChainState (TestProtocol p) = ChainState p - type ValidationErr (TestProtocol p) = ValidationErr p - type SupportedBlock (TestProtocol p) = SupportedBlock p + type NodeState (TestProtocol p) = NodeState p + type ChainState (TestProtocol p) = ChainState p + type ValidationErr (TestProtocol p) = ValidationErr p + type SupportedBlock (TestProtocol p) = SupportedBlock p - mkPayload toEnc (TestNodeConfig cfg _) (proof, stake) ph = do - standardPayload <- mkPayload toEnc cfg proof ph + mkPayload proxy (TestNodeConfig cfg _) (proof, stake) ph = do + standardPayload <- mkPayload proxy cfg proof ph return TestPayload { testPayloadP = standardPayload , testPayloadStake = stake @@ -76,7 +76,8 @@ instance OuroborosTag p => OuroborosTag (TestProtocol p) where preferCandidate (TestNodeConfig cfg _) = preferCandidate cfg compareCandidates (TestNodeConfig cfg _) = compareCandidates cfg - applyChainState toEnc (TestNodeConfig cfg _) = applyChainState toEnc cfg . fst + applyChainState (TestNodeConfig cfg _) = applyChainState cfg . fst + rewindChainState (TestNodeConfig cfg _) = rewindChainState cfg protocolSecurityParam (TestNodeConfig cfg _) = protocolSecurityParam cfg deriving instance (OuroborosTag p, Show (Payload p ph)) => Show (Payload (TestProtocol p) ph) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs index 91649534663..b54d8d93263 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs @@ -1,12 +1,14 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Miscellaneous utilities module Ouroboros.Consensus.Util ( - Dict(..) + Empty + , Dict(..) , Some(..) , SomePair(..) , foldlM' @@ -42,6 +44,9 @@ import Data.Void import Data.Word (Word64) import GHC.Stack +class Empty a +instance Empty a + data Dict (a :: Constraint) where Dict :: a => Dict a diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/CBOR.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/CBOR.hs index 176d4dca620..923c2d13384 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/CBOR.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/CBOR.hs @@ -20,8 +20,6 @@ module Ouroboros.Consensus.Util.CBOR ( import qualified Codec.CBOR.Decoding as CBOR (Decoder) import qualified Codec.CBOR.Read as CBOR -import Codec.Serialise (Serialise) -import qualified Codec.Serialise as S import Control.Exception (assert, throwIO) import Control.Monad import Control.Monad.ST @@ -52,8 +50,8 @@ fromIDecode (CBOR.Partial k) = Partial $ fmap fromIDecode . stToIO . k fromIDecode (CBOR.Done bs off x) = Done bs off x fromIDecode (CBOR.Fail bs off e) = Fail bs off e -deserialiseIncrementalIO :: Serialise a => IO (IDecodeIO a) -deserialiseIncrementalIO = fromIDecode <$> stToIO S.deserialiseIncremental +deserialiseIncrementalIO :: (forall s. CBOR.Decoder s a) -> IO (IDecodeIO a) +deserialiseIncrementalIO = fmap fromIDecode . stToIO . CBOR.deserialiseIncremental {------------------------------------------------------------------------------- Higher-level incremental interface @@ -63,7 +61,7 @@ data Decoder m = Decoder { -- | Decode next failure -- -- May throw 'CBOR.DeserialiseFailure' - decodeNext :: forall a. Serialise a => m a + decodeNext :: forall a. (forall s. CBOR.Decoder s a) -> m a } -- | Construct incremental decoder given a way to get chunks @@ -72,9 +70,9 @@ data Decoder m = Decoder { initDecoderIO :: IO ByteString -> IO (Decoder IO) initDecoderIO getChunk = do leftover <- newIORef BS.empty - let go :: forall a. Serialise a => IO a - go = do - i <- deserialiseIncrementalIO + let go :: forall a. (forall s. CBOR.Decoder s a) -> IO a + go decoder = do + i <- deserialiseIncrementalIO decoder case i of Done bs _ a -> assert (BS.null bs) $ return a Fail _ _ e -> throwIO e @@ -101,7 +99,7 @@ initDecoderIO getChunk = do data ReadIncrementalErr = -- | Could not deserialise the data - ReadFailed S.DeserialiseFailure + ReadFailed CBOR.DeserialiseFailure -- | Deserialisation was successful, but there was additional data | TrailingBytes ByteString @@ -128,17 +126,17 @@ readIncremental hasFS@HasFS{..} decoder fp = withLiftST $ \liftST -> do where go :: (forall x. ST s x -> m x) -> h - -> S.IDecode s a + -> CBOR.IDecode s a -> m (Either ReadIncrementalErr a) - go liftST h (S.Partial k) = do + go liftST h (CBOR.Partial k) = do bs <- hGetSome h (fromIntegral defaultChunkSize) dec' <- liftST $ k (checkEmpty bs) go liftST h dec' - go _ _ (S.Done leftover _ a) = + go _ _ (CBOR.Done leftover _ a) = return $ if BS.null leftover then Right a else Left $ TrailingBytes leftover - go _ _ (S.Fail _ _ err) = + go _ _ (CBOR.Fail _ _ err) = return $ Left $ ReadFailed err checkEmpty :: ByteString -> Maybe ByteString @@ -176,10 +174,10 @@ readIncrementalOffsets hasFS@HasFS{..} decoder fp = withLiftST $ \liftST -> -> [(Word64, (Word64, a))] -- ^ Already deserialised (reverse order) -> Maybe ByteString -- ^ Unconsumed bytes from last time -> Word64 -- ^ Total file size - -> S.IDecode s a + -> CBOR.IDecode s a -> m ([(Word64, (Word64, a))], Maybe ReadIncrementalErr) go liftST h offset deserialised mbUnconsumed fileSize dec = case dec of - S.Partial k -> do + CBOR.Partial k -> do -- First use the unconsumed bytes from a previous read before read -- some more bytes from the file. bs <- case mbUnconsumed of @@ -188,7 +186,7 @@ readIncrementalOffsets hasFS@HasFS{..} decoder fp = withLiftST $ \liftST -> dec' <- liftST $ k (checkEmpty bs) go liftST h offset deserialised Nothing fileSize dec' - S.Done leftover size a -> do + CBOR.Done leftover size a -> do let nextOffset = offset + fromIntegral size deserialised' = (offset, (fromIntegral size, a)) : deserialised case checkEmpty leftover of @@ -200,7 +198,7 @@ readIncrementalOffsets hasFS@HasFS{..} decoder fp = withLiftST $ \liftST -> mbLeftover -> liftST (CBOR.deserialiseIncremental decoder) >>= go liftST h nextOffset deserialised' mbLeftover fileSize - S.Fail _ _ err -> return (reverse deserialised, Just (ReadFailed err)) + CBOR.Fail _ _ err -> return (reverse deserialised, Just (ReadFailed err)) checkEmpty :: ByteString -> Maybe ByteString checkEmpty bs | BS.null bs = Nothing @@ -254,10 +252,10 @@ readIncrementalOffsetsEBB chunkSize hasFS decoder getEBBHash fp = withLiftST $ \ -> Maybe ByteString -- ^ Unconsumed bytes from last time -> [ByteString] -- ^ Bytes fed to the decoder so far, reverse. -> Word64 -- ^ Total file size - -> S.IDecode s a + -> CBOR.IDecode s a -> m ([(Word64, (Word64, a))], Maybe hash, Maybe ReadIncrementalErr) go liftST h !offset !deserialised !mbEBBHash !mbUnconsumed !consumed fileSize dec = case dec of - S.Partial k -> case mbUnconsumed of + CBOR.Partial k -> case mbUnconsumed of Just bs -> do dec' <- liftST $ k (Just bs) go liftST h offset deserialised mbEBBHash Nothing (bs : consumed) fileSize dec' @@ -269,7 +267,7 @@ readIncrementalOffsetsEBB chunkSize hasFS decoder getEBBHash fp = withLiftST $ \ dec' <- liftST $ k (checkEmpty bs) go liftST h offset deserialised mbEBBHash Nothing (bs : consumed) fileSize dec' - S.Done leftover size a -> do + CBOR.Done leftover size a -> do let nextOffset = offset + fromIntegral size deserialised' = (offset, (fromIntegral size, a)) : deserialised consumedBytes = BSL.take size (BSL.fromChunks (reverse consumed)) @@ -289,7 +287,7 @@ readIncrementalOffsetsEBB chunkSize hasFS decoder getEBBHash fp = withLiftST $ \ go liftST h nextOffset deserialised' mbEBBHash' mbLeftover [] fileSize dec' - S.Fail _ _ err -> return + CBOR.Fail _ _ err -> return (reverse deserialised, mbEBBHash, Just (ReadFailed err)) checkEmpty :: ByteString -> Maybe ByteString diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/SlotBounded.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/SlotBounded.hs new file mode 100644 index 00000000000..b096c47dd7a --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/SlotBounded.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveFunctor #-} + +-- | Intended for qualified import +module Ouroboros.Consensus.Util.SlotBounded ( + SlotBounded(..) + , bounded + , unbounded + , at + ) where + +import Ouroboros.Network.Block (SlotNo) + +-- | An item bounded to be valid within particular slots +data SlotBounded a = SlotBounded + { sbLower :: !SlotNo + , sbUpper :: !SlotNo + , sbContent :: !a + } deriving (Eq, Functor, Show) + +-- | Construct a slot bounded item. +-- +-- We choose not to validate that the slot bounds are reasonable here. +bounded :: SlotNo -> SlotNo -> a -> SlotBounded a +bounded = SlotBounded + +unbounded :: a -> SlotBounded a +unbounded = SlotBounded minBound maxBound + +at :: SlotBounded a -> SlotNo -> Maybe a +sb `at` slot = + if (slot <= sbUpper sb && slot >= sbLower sb) + then Just $ sbContent sb + else Nothing diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Mock.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Mock.hs index bce2b182cf4..7eacad8ec38 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Mock.hs @@ -9,7 +9,6 @@ module Ouroboros.Storage.ChainDB.Mock ( import Data.Bifunctor (first) import qualified Data.Set as Set -import Codec.CBOR.Encoding (Encoding) import Control.Monad.Class.MonadSTM import Ouroboros.Network.Block (ChainUpdate (..), HasHeader (..), @@ -31,13 +30,13 @@ openDB :: forall m blk hdr. , HasHeader hdr , HeaderHash blk ~ HeaderHash hdr , ProtocolLedgerView blk + , LedgerConfigView blk ) - => (PreHeader blk -> Encoding) - -> NodeConfig (BlockProtocol blk) + => NodeConfig (BlockProtocol blk) -> ExtLedgerState blk -> (blk -> hdr) -> m (ChainDB m blk hdr) -openDB toEnc cfg initLedger blockHeader = do +openDB cfg initLedger blockHeader = do db :: TVar m (Model blk) <- atomically $ newTVar (Model.empty initLedger) let query :: (Model blk -> a) -> STM m a @@ -91,7 +90,7 @@ openDB toEnc cfg initLedger blockHeader = do . Model.readerForward rdrId (map Block.castPoint ps) return ChainDB { - addBlock = update_ . Model.addBlock toEnc cfg + addBlock = update_ . Model.addBlock cfg , getCurrentChain = query $ Model.lastK k blockHeader , getCurrentLedger = query $ Model.currentLedger , getBlock = query' . Model.getBlockByPoint diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs index 22f2177dcf9..819a163830c 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs @@ -31,7 +31,6 @@ module Ouroboros.Storage.ChainDB.Model ( , readerForward ) where -import Codec.CBOR.Encoding (Encoding) import Control.Monad.Except (runExcept) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -117,11 +116,9 @@ empty initLedger = Model { , iterators = Map.empty } -addBlock :: forall blk. ProtocolLedgerView blk - => (PreHeader blk -> Encoding) - -> NodeConfig (BlockProtocol blk) - -> blk -> Model blk -> Model blk -addBlock toEnc cfg blk m = Model { +addBlock :: forall blk. (ProtocolLedgerView blk, LedgerConfigView blk) + => NodeConfig (BlockProtocol blk) -> blk -> Model blk -> Model blk +addBlock cfg blk m = Model { blocks = blocks' , cps = CPS.switchFork newChain (cps m) , currentLedger = newLedger @@ -133,18 +130,16 @@ addBlock toEnc cfg blk m = Model { blocks' = Map.insert (Block.blockHash blk) blk (blocks m) candidates :: [(Chain blk, ExtLedgerState blk)] - candidates = mapMaybe (validate toEnc cfg (initLedger m)) $ chains blocks' + candidates = mapMaybe (validate cfg (initLedger m)) $ chains blocks' newChain :: Chain blk newLedger :: ExtLedgerState blk (newChain, newLedger) = fromMaybe (currentChain m, currentLedger m) $ selectChain cfg (currentChain m) candidates -addBlocks :: forall blk. ProtocolLedgerView blk - => (PreHeader blk -> Encoding) - -> NodeConfig (BlockProtocol blk) - -> [blk] -> Model blk -> Model blk -addBlocks toEnc cfg = repeatedly (addBlock toEnc cfg) +addBlocks :: forall blk. (ProtocolLedgerView blk, LedgerConfigView blk) + => NodeConfig (BlockProtocol blk) -> [blk] -> Model blk -> Model blk +addBlocks cfg = repeatedly (addBlock cfg) {------------------------------------------------------------------------------- Iterators @@ -217,16 +212,23 @@ notGenesis p = GenesisHash -> error "Ouroboros.Storage.ChainDB.Model: notGenesis" BlockHash h -> h -validate :: ProtocolLedgerView blk - => (PreHeader blk -> Encoding) - -> NodeConfig (BlockProtocol blk) +validate :: forall blk. + ( ProtocolLedgerView blk + , LedgerConfigView blk + ) + => NodeConfig (BlockProtocol blk) -> ExtLedgerState blk -> Chain blk -> Maybe (Chain blk, ExtLedgerState blk) -validate toEnc cfg initLedger chain = - either (const Nothing) (\ledger -> Just (chain, ledger)) +validate cfg initLedger chain = + fromEither . runExcept - $ chainExtLedgerState toEnc cfg chain initLedger + $ chainExtLedgerState cfg chain initLedger + where + fromEither :: Either (ExtValidationError blk) (ExtLedgerState blk) + -> Maybe (Chain blk, ExtLedgerState blk) + fromEither (Left _err) = Nothing + fromEither (Right l) = Just (chain, l) chains :: forall blk. (HasHeader blk) => Map (HeaderHash blk) blk -> [Chain blk] diff --git a/ouroboros-consensus/src/Ouroboros/Storage/LedgerDB/InMemory.hs b/ouroboros-consensus/src/Ouroboros/Storage/LedgerDB/InMemory.hs index d30804eaa7a..390e552e0af 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/LedgerDB/InMemory.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/LedgerDB/InMemory.hs @@ -101,14 +101,14 @@ data Apply :: Bool -> * where -- | Not previously applied -- -- All checks must be performed - Apply :: Apply False + Apply :: Apply 'False -- | Error we get from applying a block -- -- If the block was previously applied, we can't get any errors. type family Err (ap :: Bool) (e :: *) :: * where - Err True e = Void - Err False e = e + Err 'True e = Void + Err 'False e = e -- | Pass a block by value or by reference data RefOrVal r b = Ref r | Val r b @@ -204,7 +204,7 @@ reapplyBlock :: forall m l r b e. Monad m => LedgerDbConf m l r b e -> RefOrVal r b -> l -> m l reapplyBlock cfg b = fmap mustBeRight . runExceptT - . applyBlock cfg (Reapply @True, b) + . applyBlock cfg (Reapply @'True, b) {------------------------------------------------------------------------------- Queries @@ -306,7 +306,7 @@ ledgerDbPush cfg (pa, new) ldb = runExceptT $ ledgerDbReapply :: Monad m => LedgerDbConf m l r b e -> RefOrVal r b -> LedgerDB l r -> m (LedgerDB l r) -ledgerDbReapply cfg b = fmap mustBeRight . ledgerDbPush cfg (Reapply @True, b) +ledgerDbReapply cfg b = fmap mustBeRight . ledgerDbPush cfg (Reapply @'True, b) -- | Push a bunch of blocks (oldest first) ledgerDbPushMany :: Monad m diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs b/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs index d94534850df..55834658725 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs @@ -4,7 +4,6 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Consensus.ChainSyncClient ( tests ) where -import Codec.Serialise (encode) import Control.Monad (replicateM_, void) import Control.Monad.Except (runExcept) import Control.Monad.State.Strict @@ -101,12 +100,13 @@ prop_chainSync ChainSyncClientSetup {..} = label "InvalidRollBack" $ counterexample ("InvalidRollBack intersection: " <> ppPoint intersection) $ not (AF.withinFragmentBounds intersection synchedChain) - Just e -> counterexample (displayException e) False - Nothing -> synchedChain `isSuffix` serverChain .&&. - -- TODO in the future we might strengthen this - -- to: must fork at most k blocks back from the - -- current tip - synchedChain `intersects` clientChain + Just e -> + counterexample ("Exception: " ++ displayException e) False + Nothing -> + synchedChain `isSuffix` serverChain .&&. + -- TODO in the future we might strengthen this to: must fork at most k + -- blocks back from the current tip + synchedChain `intersects` clientChain where k = maxRollbacks securityParam @@ -145,7 +145,7 @@ serverId :: CoreNodeId serverId = CoreNodeId 1 -- | Terser notation -type ChainSyncException = ChainSyncClientException TestBlock TestBlock +type ChainSyncException = ChainSyncClientException TestBlock -- | Using slots as times, a schedule plans updates to a chain on certain -- slots. @@ -353,13 +353,13 @@ updateClientState cfg chain ledgerState chainUpdates = where chain' = foldl' (flip Chain.addBlock) chain bs ledgerState' = runValidate $ - foldExtLedgerState encode cfg bs ledgerState + foldExtLedgerState cfg bs ledgerState Nothing -- There was a roll back in the updates, so validate the chain from -- scratch | Just chain' <- Chain.applyChainUpdates chainUpdates chain -> let ledgerState' = runValidate $ - chainExtLedgerState encode cfg chain' testInitExtLedger + chainExtLedgerState cfg chain' testInitExtLedger in (chain', ledgerState') | otherwise -> error "Client chain update failed" @@ -371,7 +371,6 @@ updateClientState cfg chain ledgerState chainUpdates = Left _ -> error "Client ledger validation error" Right x -> x - {------------------------------------------------------------------------------- ChainSyncClientSetup -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs index 51f7fd256a2..fe668f9dfbd 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs @@ -24,6 +24,7 @@ import Test.Tasty.QuickCheck import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Demo +import Ouroboros.Consensus.Ledger.Mock import Ouroboros.Consensus.Node import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util.Random @@ -55,12 +56,16 @@ prop_simple_bft_convergence k numCoreNodes = numCoreNodes where isValid :: [NodeId] - -> Map NodeId (Chain (Block DemoBFT)) + -> Map NodeId ( NodeConfig DemoBFT + , Chain (SimpleBlock DemoBFT SimpleBlockMockCrypto)) -> Property - isValid nodeIds final = counterexample (show final) $ - tabulate "shortestLength" [show (rangeK k (shortestLength final))] + isValid nodeIds final = counterexample (show final') $ + tabulate "shortestLength" [show (rangeK k (shortestLength final'))] $ Map.keys final === nodeIds - .&&. allEqual (takeChainPrefix <$> Map.elems final) + .&&. allEqual (takeChainPrefix <$> Map.elems final') where - takeChainPrefix :: Chain (Block DemoBFT) -> Chain (Block DemoBFT) + -- Without the 'NodeConfig's + final' = snd <$> final + takeChainPrefix :: Chain (SimpleBlock DemoBFT SimpleBlockMockCrypto) + -> Chain (SimpleBlock DemoBFT SimpleBlockMockCrypto) takeChainPrefix = id -- in BFT, chains should indeed all be equal. diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs index 347643480a8..dabfedbe023 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs @@ -29,17 +29,22 @@ import Ouroboros.Network.Chain import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Demo +import Ouroboros.Consensus.Ledger.Mock import Ouroboros.Consensus.Node +import Ouroboros.Consensus.Protocol.Abstract (NodeConfig) import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.Random import Ouroboros.Consensus.Util.ThreadRegistry import Test.Dynamic.Network -prop_simple_protocol_convergence :: forall p. DemoProtocolConstraints p - => (CoreNodeId -> ProtocolInfo p) +prop_simple_protocol_convergence :: forall p c. + ( RunDemo (SimpleBlock p c) (SimpleHeader p c) + , SimpleBlockCrypto c + ) + => (CoreNodeId -> ProtocolInfo (SimpleBlock p c)) -> ( [NodeId] - -> Map NodeId (Chain (Block p)) + -> Map NodeId (NodeConfig p, Chain (SimpleBlock p c)) -> Property) -> NumCoreNodes -> NumSlots @@ -50,7 +55,7 @@ prop_simple_protocol_convergence pInfo isValid numCoreNodes numSlots seed = test_simple_protocol_convergence pInfo isValid numCoreNodes numSlots seed -- Run protocol on the broadcast network, and check resulting chains on all nodes. -test_simple_protocol_convergence :: forall m p. +test_simple_protocol_convergence :: forall m p c. ( MonadAsync m , MonadFork m , MonadMask m @@ -58,11 +63,12 @@ test_simple_protocol_convergence :: forall m p. , MonadTime m , MonadTimer m , MonadThrow (STM m) - , DemoProtocolConstraints p + , RunDemo (SimpleBlock p c) (SimpleHeader p c) + , SimpleBlockCrypto c ) - => (CoreNodeId -> ProtocolInfo p) + => (CoreNodeId -> ProtocolInfo (SimpleBlock p c)) -> ( [NodeId] - -> Map NodeId (Chain (Block p)) + -> Map NodeId (NodeConfig p, Chain (SimpleBlock p c)) -> Property) -> NumCoreNodes -> NumSlots diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs index 67e48e35e4c..16f73d03b1d 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs @@ -33,6 +33,7 @@ import Ouroboros.Network.Chain (Chain) import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Demo +import Ouroboros.Consensus.Ledger.Mock import Ouroboros.Consensus.Node import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.LeaderSchedule @@ -81,15 +82,20 @@ prop_simple_leader_schedule_convergence numSlots numCoreNodes params seed = seed where isValid :: [NodeId] - -> Map NodeId (Chain (Block DemoLeaderSchedule)) + -> Map NodeId ( NodeConfig DemoLeaderSchedule + , Chain (SimpleBlock DemoLeaderSchedule SimpleBlockMockCrypto)) -> Property isValid nodeIds final = - counterexample (tracesToDot final) - $ tabulate "shortestLength" [show (rangeK (praosSecurityParam params) (shortestLength final))] - $ Map.keys final === nodeIds - .&&. prop_all_common_prefix - (maxRollbacks $ praosSecurityParam params) - (Map.elems final) + counterexample (tracesToDot final) + $ tabulate "shortestLength" + [show (rangeK (praosSecurityParam params) (shortestLength final'))] + $ Map.keys final === nodeIds + .&&. prop_all_common_prefix + (maxRollbacks $ praosSecurityParam params) + (Map.elems final') + where + -- Without the 'NodeConfig's + final' = snd <$> final {------------------------------------------------------------------------------- Dependent generation and shrinking of leader schedules diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs index 3f34f1f3712..df1fdb8b5d7 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs @@ -10,7 +10,6 @@ module Test.Dynamic.Network ( broadcastNetwork ) where -import Codec.Serialise (Serialise (encode)) import Control.Monad import Control.Tracer (nullTracer) import Crypto.Number.Generate (generateBetween) @@ -32,7 +31,6 @@ import Ouroboros.Network.Codec (AnyMessage, Codec) import Ouroboros.Network.Block import Ouroboros.Network.Chain -import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Network.Protocol.BlockFetch.Codec import Ouroboros.Network.Protocol.BlockFetch.Type import Ouroboros.Network.Protocol.ChainSync.Codec @@ -45,6 +43,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Mock import qualified Ouroboros.Consensus.Ledger.Mock as Mock import Ouroboros.Consensus.Node +import Ouroboros.Consensus.Protocol.Abstract (NodeConfig) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.Random @@ -60,7 +59,7 @@ import qualified Ouroboros.Storage.ChainDB.Mock as ChainDB -- -- We run for the specified number of blocks, then return the final state of -- each node. -broadcastNetwork :: forall m p blk hdr. +broadcastNetwork :: forall m p c. ( MonadAsync m , MonadFork m , MonadMask m @@ -68,17 +67,16 @@ broadcastNetwork :: forall m p blk hdr. , MonadTime m , MonadTimer m , MonadThrow (STM m) - , DemoProtocolConstraints p - , blk ~ Block p - , hdr ~ Header p + , RunDemo (SimpleBlock p c) (SimpleHeader p c) + , SimpleBlockCrypto c ) => ThreadRegistry m -> BlockchainTime m -> NumCoreNodes - -> (CoreNodeId -> ProtocolInfo p) + -> (CoreNodeId -> ProtocolInfo (SimpleBlock p c)) -> ChaChaDRG -> NumSlots - -> m (Map NodeId (Chain blk)) + -> m (Map NodeId (NodeConfig p, Chain (SimpleBlock p c))) broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do -- all known addresses @@ -91,7 +89,7 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do nodeAddrs = map fst (Map.elems nodeUtxo) ] - chans :: NodeChans m blk hdr <- createCommunicationChannels + chans :: NodeChans m (SimpleBlock p c) (SimpleHeader p c) <- createCommunicationChannels varRNG <- atomically $ newTVar initRNG @@ -99,26 +97,29 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do let us = fromCoreNodeId coreNodeId ProtocolInfo{..} = pInfo coreNodeId - let callbacks :: NodeCallbacks m blk + let callbacks :: NodeCallbacks m (SimpleBlock p c) callbacks = NodeCallbacks { produceBlock = \proof l slot prevPoint prevNo _txs -> do - let prevHash = castHash (Chain.pointHash prevPoint) - curNo = succ prevNo + let curNo :: BlockNo + curNo = succ prevNo + + let prevHash :: ChainHash (SimpleHeader p c) + prevHash = castHash (pointHash prevPoint) -- We ignore the transactions from the mempool (which will be -- empty), and instead produce some random transactions txs <- genTxs addrs (getUtxo l) - forgeBlock pInfoConfig - slot - curNo - prevHash - txs - proof + demoForgeBlock pInfoConfig + slot + curNo + prevHash + (map SimpleGenTx txs) + proof , produceDRG = atomically $ simChaChaT varRNG id $ drgNew } - chainDB <- ChainDB.openDB encode pInfoConfig pInfoInitLedger simpleHeader + chainDB <- ChainDB.openDB pInfoConfig pInfoInitLedger simpleHeader let nodeParams = NodeParams { tracer = nullTracer @@ -137,7 +138,7 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do forM_ (filter (/= us) nodeIds) $ \them -> do let mkCommsDown :: Show bytes - => (NodeChan m blk hdr -> Channel m bytes) + => (NodeChan m (SimpleBlock p c) (SimpleHeader p c) -> Channel m bytes) -> Codec ps e m bytes -> NodeComms m ps e bytes mkCommsDown getChan codec = NodeComms { ncCodec = codec @@ -146,7 +147,7 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do getChan (chans Map.! us Map.! them) } mkCommsUp :: Show bytes - => (NodeChan m blk hdr -> Channel m bytes) + => (NodeChan m (SimpleBlock p c) (SimpleHeader p c) -> Channel m bytes) -> Codec ps e m bytes -> NodeComms m ps e bytes mkCommsUp getChan codec = NodeComms { ncCodec = codec @@ -161,7 +162,7 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do (mkCommsUp chainSyncProducer codecChainSyncId) (mkCommsUp blockFetchProducer codecBlockFetchId) - return (us, node) + return (coreNodeId, node) -- STM variable to record the final chains of the nodes varRes <- atomically $ newTVar Nothing @@ -170,8 +171,9 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do -- Wait a random amount of time after the final slot for the block fetch -- and chain sync to finish threadDelay 2000 - res <- fmap Map.fromList $ forM nodes $ \(us, node) -> - (us, ) <$> ChainDB.toChain (getChainDB node) + res <- fmap Map.fromList $ forM nodes $ \(cid, node) -> + (\ch -> (fromCoreNodeId cid, (pInfoConfig (pInfo cid), ch))) <$> + ChainDB.toChain (getChainDB node) atomically $ writeTVar varRes (Just res) atomically $ blockUntilJust (readTVar varRes) @@ -182,10 +184,10 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do coreNodeIds :: [CoreNodeId] coreNodeIds = enumCoreNodes numCoreNodes - getUtxo :: ExtLedgerState blk -> Utxo + getUtxo :: ExtLedgerState (SimpleBlock p c) -> Utxo getUtxo = slsUtxo . ledgerState - createCommunicationChannels :: m (NodeChans m blk hdr) + createCommunicationChannels :: m (NodeChans m (SimpleBlock p c) (SimpleHeader p c)) createCommunicationChannels = fmap Map.fromList $ forM nodeIds $ \us -> fmap ((us, ) . Map.fromList) $ forM (filter (/= us) nodeIds) $ \them -> do (chainSyncConsumer, chainSyncProducer) <- createConnectedChannels diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs index 6ce440ff660..f5734ebf4a0 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs @@ -29,6 +29,7 @@ import Test.Tasty.QuickCheck import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Demo +import Ouroboros.Consensus.Ledger.Mock import Ouroboros.Consensus.Node import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.PBFT @@ -56,7 +57,7 @@ prop_simple_pbft_convergence :: SecurityParam -> Property prop_simple_pbft_convergence sp numCoreNodes@(NumCoreNodes nn) = prop_simple_protocol_convergence - (protocolInfo (DemoPBFT params) numCoreNodes) + (protocolInfo (DemoMockPBFT params) numCoreNodes) isValid numCoreNodes where @@ -64,12 +65,16 @@ prop_simple_pbft_convergence sp numCoreNodes@(NumCoreNodes nn) = sigThd = (1.0 / fromIntegral nn) + 0.1 params = PBftParams sp (fromIntegral nn) sigWin sigThd isValid :: [NodeId] - -> Map NodeId (Chain (Block DemoPBFT)) + -> Map NodeId ( NodeConfig DemoMockPBFT + , Chain (SimpleBlock DemoMockPBFT SimpleBlockMockCrypto)) -> Property - isValid nodeIds final = counterexample (show final) $ - tabulate "shortestLength" [show (rangeK sp (shortestLength final))] + isValid nodeIds final = counterexample (show final') $ + tabulate "shortestLength" [show (rangeK sp (shortestLength final'))] $ Map.keys final === nodeIds - .&&. allEqual (takeChainPrefix <$> Map.elems final) + .&&. allEqual (takeChainPrefix <$> Map.elems final') where - takeChainPrefix :: Chain (Block DemoPBFT) -> Chain (Block DemoPBFT) + -- Without the 'NodeConfig's + final' = snd <$> final + takeChainPrefix :: Chain (SimpleBlock DemoMockPBFT SimpleBlockMockCrypto) + -> Chain (SimpleBlock DemoMockPBFT SimpleBlockMockCrypto) takeChainPrefix = id -- in PBFT, chains should indeed all be equal. diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs index 39c6df6ca0c..7427173d384 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs @@ -35,6 +35,7 @@ import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Demo +import Ouroboros.Consensus.Ledger.Mock import Ouroboros.Consensus.Node (NodeId) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Praos @@ -92,24 +93,30 @@ prop_simple_praos_convergence params numCoreNodes numSlots = PraosParams{..} = params isValid :: [NodeId] - -> Map NodeId (Chain (Block DemoPraos)) + -> Map NodeId ( NodeConfig DemoPraos + , Chain (SimpleBlock DemoPraos SimpleBlockMockCrypto)) -> Property - isValid nodeIds final = counterexample (show final) $ - let schedule = leaderScheduleFromTrace numSlots final - longest = longestCrowdedRun schedule - crowded = crowdedRunLength longest - in counterexample (tracesToDot final) - $ counterexample (condense schedule) - $ counterexample (show longest) - $ label ("longest crowded run " <> show crowded) - $ tabulate "shortestLength" [show (rangeK praosSecurityParam (shortestLength final))] - $ (Map.keys final === nodeIds) - .&&. if crowded > maxRollbacks praosSecurityParam - then label "too crowded" $ property True - else label "not too crowded" $ - prop_all_common_prefix - (maxRollbacks praosSecurityParam) - (Map.elems final) + isValid nodeIds final + = counterexample (show final') + $ counterexample (tracesToDot final) + $ counterexample (condense schedule) + $ counterexample (show longest) + $ label ("longest crowded run " <> show crowded) + $ tabulate "shortestLength" + [show (rangeK praosSecurityParam (shortestLength final'))] + $ (Map.keys final === nodeIds) + .&&. if crowded > maxRollbacks praosSecurityParam + then label "too crowded" $ property True + else label "not too crowded" $ + prop_all_common_prefix + (maxRollbacks praosSecurityParam) + (Map.elems final') + where + -- Without the 'NodeConfig's + final' = snd <$> final + schedule = leaderScheduleFromTrace numSlots final + longest = longestCrowdedRun schedule + crowded = crowdedRunLength longest prop_all_common_prefix :: (HasHeader b, Condense b, Eq b) => Word64 -> [Chain b] -> Property diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs index bf4765ed6b8..d4f88f7109c 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module Test.Dynamic.Util ( allEqual @@ -34,7 +36,9 @@ import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Demo (HasCreator (..)) +import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Node +import Ouroboros.Consensus.Protocol.Abstract (NodeConfig) import Ouroboros.Consensus.Protocol.LeaderSchedule (LeaderSchedule (..)) import qualified Ouroboros.Consensus.Util.Chain as Chain @@ -96,10 +100,12 @@ genesisBlockInfo = BlockInfo , biPrevious = Nothing } -blockInfo :: (HasHeader b, HasCreator b) => b -> BlockInfo b -blockInfo b = BlockInfo + +blockInfo :: (HasHeader b, HasCreator b) + => NodeConfig (BlockProtocol b) -> b -> BlockInfo b +blockInfo nc b = BlockInfo { biSlot = blockSlot b - , biCreator = Just $ getCreator b + , biCreator = Just $ getCreator nc b , biHash = BlockHash $ blockHash b , biPrevious = Just $ blockPrevHash b } @@ -135,18 +141,19 @@ instance Labellable EdgeLabel where toLabelValue = const $ StrLabel Text.empty tracesToDot :: forall b. (HasHeader b, HasCreator b) - => Map NodeId (Chain b) + => Map NodeId (NodeConfig (BlockProtocol b), Chain b) -> String tracesToDot traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph where - chainBlockInfos :: Chain b -> Map (ChainHash b) (BlockInfo b) - chainBlockInfos = Chain.foldChain f (Map.singleton GenesisHash genesisBlockInfo) + chainBlockInfos :: NodeConfig (BlockProtocol b) -> Chain b + -> Map (ChainHash b) (BlockInfo b) + chainBlockInfos nc = Chain.foldChain f (Map.singleton GenesisHash genesisBlockInfo) where - f m b = let info = blockInfo b + f m b = let info = blockInfo nc b in Map.insert (biHash info) info m blockInfos :: Map (ChainHash b) (BlockInfo b) - blockInfos = Map.unions $ map chainBlockInfos $ Map.elems traces + blockInfos = Map.unions $ map (uncurry chainBlockInfos) $ Map.elems traces lastHash :: Chain b -> ChainHash b lastHash Genesis = GenesisHash @@ -157,8 +164,9 @@ tracesToDot traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph where i = (\info -> (info, Set.empty)) <$> blockInfos - f m nid chain = Map.adjust - (\(info, believers) -> (info, Set.insert nid believers)) + f m nid (_, chain) = Map.adjust + (\(info, believers) -> + (info, Set.insert nid believers)) (lastHash chain) m @@ -189,16 +197,19 @@ tracesToDot traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph leaderScheduleFromTrace :: forall b. (HasCreator b, HasHeader b) => NumSlots - -> Map NodeId (Chain b) + -> Map NodeId (NodeConfig (BlockProtocol b), Chain b) -> LeaderSchedule -leaderScheduleFromTrace (NumSlots numSlots) = - LeaderSchedule . Map.foldl' (Chain.foldChain step) initial +leaderScheduleFromTrace (NumSlots numSlots) = LeaderSchedule . + Map.foldl' (\m (nc, c) -> Chain.foldChain (step nc) m c) initial where initial :: Map SlotNo [CoreNodeId] initial = Map.fromList [(slot, []) | slot <- [1 .. fromIntegral numSlots]] - step :: Map SlotNo [CoreNodeId] -> b -> Map SlotNo [CoreNodeId] - step m b = Map.adjust (insert $ getCreator b) (blockSlot b) m + step :: NodeConfig (BlockProtocol b) + -> Map SlotNo [CoreNodeId] + -> b + -> Map SlotNo [CoreNodeId] + step nc m b = Map.adjust (insert $ getCreator nc b) (blockSlot b) m insert :: CoreNodeId -> [CoreNodeId] -> [CoreNodeId] insert nid xs diff --git a/ouroboros-consensus/test-crypto/Test/Crypto/DSIGN.hs b/ouroboros-consensus/test-crypto/Test/Crypto/DSIGN.hs index 4766065c58d..70c287c150d 100644 --- a/ouroboros-consensus/test-crypto/Test/Crypto/DSIGN.hs +++ b/ouroboros-consensus/test-crypto/Test/Crypto/DSIGN.hs @@ -7,7 +7,7 @@ module Test.Crypto.DSIGN ) where import Data.Proxy (Proxy (..)) -import Test.QuickCheck (Property, (==>)) +import Test.QuickCheck (Property, (==>), (===), (=/=)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -32,6 +32,7 @@ tests = testDSIGNAlgorithm :: forall proxy v. ( DSIGNAlgorithm v , Serialise (VerKeyDSIGN v), Serialise (SignKeyDSIGN v), Serialise (SigDSIGN v) + , Signable v Int )=> proxy v -> String -> TestTree testDSIGNAlgorithm _ n = testGroup n @@ -43,17 +44,17 @@ testDSIGNAlgorithm _ n = , testProperty "verify newgative (wrong message)" $ prop_dsign_verify_neg_msg @Int @v ] -prop_dsign_verify_pos :: forall a v. (Serialise a, DSIGNAlgorithm v) +prop_dsign_verify_pos :: forall a v. (Serialise a, DSIGNAlgorithm v, Signable v a) => Seed -> a -> SignKeyDSIGN v - -> Bool + -> Property prop_dsign_verify_pos seed a sk = let sig = withSeed seed $ signDSIGN encode a sk vk = deriveVerKeyDSIGN sk - in verifyDSIGN encode vk a sig + in verifyDSIGN encode vk a sig === Right () -prop_dsign_verify_neg_key :: forall a v. (Serialise a, DSIGNAlgorithm v) +prop_dsign_verify_neg_key :: forall a v. (Serialise a, DSIGNAlgorithm v, Signable v a) => Seed -> a -> SignKeyDSIGN v @@ -62,9 +63,9 @@ prop_dsign_verify_neg_key :: forall a v. (Serialise a, DSIGNAlgorithm v) prop_dsign_verify_neg_key seed a sk sk' = sk /= sk' ==> let sig = withSeed seed $ signDSIGN encode a sk' vk = deriveVerKeyDSIGN sk - in not $ verifyDSIGN encode vk a sig + in verifyDSIGN encode vk a sig =/= Right () -prop_dsign_verify_neg_msg :: forall a v. (Serialise a, Eq a, DSIGNAlgorithm v) +prop_dsign_verify_neg_msg :: forall a v. (Serialise a, Eq a, DSIGNAlgorithm v, Signable v a) => Seed -> a -> a @@ -73,4 +74,4 @@ prop_dsign_verify_neg_msg :: forall a v. (Serialise a, Eq a, DSIGNAlgorithm v) prop_dsign_verify_neg_msg seed a a' sk = a /= a' ==> let sig = withSeed seed $ signDSIGN encode a sk vk = deriveVerKeyDSIGN sk - in not $ verifyDSIGN encode vk a' sig + in verifyDSIGN encode vk a' sig =/= Right () diff --git a/ouroboros-consensus/test-crypto/Test/Crypto/KES.hs b/ouroboros-consensus/test-crypto/Test/Crypto/KES.hs index 5b8999547f6..c4336aa450e 100644 --- a/ouroboros-consensus/test-crypto/Test/Crypto/KES.hs +++ b/ouroboros-consensus/test-crypto/Test/Crypto/KES.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Test.Crypto.KES @@ -19,9 +20,12 @@ import Test.Tasty.QuickCheck (testProperty) import Ouroboros.Consensus.Crypto.DSIGN import Ouroboros.Consensus.Crypto.KES +import qualified Ouroboros.Consensus.Crypto.KES as KES +import Ouroboros.Consensus.Util (Empty) import Ouroboros.Consensus.Util.Random -import Ouroboros.Network.Testing.Serialise (Serialise(..), prop_serialise) +import Ouroboros.Network.Testing.Serialise (Serialise (..), + prop_serialise) import Test.Util.Orphans.Arbitrary () import Test.Util.QuickCheck @@ -35,9 +39,11 @@ tests = , testKESAlgorithm (Proxy :: Proxy (SimpleKES Ed448DSIGN)) "SimpleKES (with Ed448)" ] -testKESAlgorithm :: (KESAlgorithm v - , Serialise (VerKeyKES v), Serialise (SignKeyKES v), Serialise (SigKES v) - ) => proxy v -> String -> TestTree +testKESAlgorithm :: ( KESAlgorithm v + , Serialise (VerKeyKES v), Serialise (SignKeyKES v), Serialise (SigKES v) + , KES.Signable v ~ Empty + ) + => proxy v -> String -> TestTree testKESAlgorithm p n = testGroup n [ testProperty "serialise VerKey" $ prop_KES_serialise_VerKey p @@ -63,7 +69,10 @@ prop_KES_serialise_SignKey :: (KESAlgorithm v, Serialise (SignKeyKES v)) prop_KES_serialise_SignKey _ (Duration_Seed_SK _ _ sk _) = prop_serialise sk -prop_KES_serialise_Sig :: (KESAlgorithm v, Serialise (SigKES v)) +prop_KES_serialise_Sig :: ( KESAlgorithm v + , KES.Signable v ~ Empty + , Serialise (SigKES v) + ) => proxy v -> Duration_Seed_SK_Times v String -> Seed @@ -72,7 +81,7 @@ prop_KES_serialise_Sig _ d seed = case withSeed seed $ trySign d of Left e -> counterexample e False Right xs -> conjoin [prop_serialise sig |(_, _, sig) <- xs] -prop_KES_verify_pos :: KESAlgorithm v +prop_KES_verify_pos :: (KESAlgorithm v, KES.Signable v ~ Empty) => proxy v -> Duration_Seed_SK_Times v String -> Seed @@ -81,9 +90,11 @@ prop_KES_verify_pos _ d seed = let vk = getFirstVerKey d in case withSeed seed $ trySign d of Left e -> counterexample e False - Right xs -> conjoin [verifyKES encode vk j a sig | (j, a, sig) <- xs] + Right xs -> conjoin [ verifyKES encode vk j a sig === Right () + | (j, a, sig) <- xs + ] -prop_KES_verify_neg_key :: KESAlgorithm v +prop_KES_verify_neg_key :: (KESAlgorithm v, KES.Signable v ~ Empty) => proxy v -> Duration_Seed_SK_Times v Int -> Seed @@ -91,10 +102,11 @@ prop_KES_verify_neg_key :: KESAlgorithm v prop_KES_verify_neg_key _ d seed = getDuration d > 0 ==> case withSeed seed $ trySign d of Left e -> counterexample e False - Right xs -> conjoin [ not $ verifyKES encode (getSecondVerKey d) j a sig - | (j, a, sig) <- xs] + Right xs -> conjoin [ verifyKES encode (getSecondVerKey d) j a sig =/= Right () + | (j, a, sig) <- xs + ] -prop_KES_verify_neg_msg :: KESAlgorithm v +prop_KES_verify_neg_msg :: (KESAlgorithm v, KES.Signable v ~ Empty) => proxy v -> Duration_Seed_SK_Times v Double -> Double @@ -104,9 +116,11 @@ prop_KES_verify_neg_msg _ d a seed = let vk = getFirstVerKey d in case withSeed seed $ trySign d of Left e -> counterexample e False - Right xs -> conjoin [a /= a' ==> not $ verifyKES encode vk j a sig | (j, a', sig) <- xs] + Right xs -> conjoin [ a /= a' ==> verifyKES encode vk j a sig =/= Right () + | (j, a', sig) <- xs + ] -prop_KES_verify_neg_time :: KESAlgorithm v +prop_KES_verify_neg_time :: (KESAlgorithm v, KES.Signable v ~ Empty) => proxy v -> Duration_Seed_SK_Times v Double -> Integer @@ -117,7 +131,9 @@ prop_KES_verify_neg_time _ d i = t = fromIntegral $ abs i in case withSeed seed $ trySign d of Left e -> counterexample e False - Right xs -> conjoin [t /= j ==> not $ verifyKES encode vk t a sig | (j, a, sig) <- xs] + Right xs -> conjoin [ t /= j ==> verifyKES encode vk t a sig =/= Right () + | (j, a, sig) <- xs + ] getDuration :: Duration_Seed_SK_Times v a -> Natural getDuration d = case d of @@ -134,8 +150,10 @@ getSecondVerKey d = case d of trySign :: forall m v a. ( MonadRandom m , KESAlgorithm v + , KES.Signable v ~ Empty , Serialise a - , Show a) + , Show a + ) => Duration_Seed_SK_Times v a -> m (Either String [(Natural, a, SigKES v)]) trySign (Duration_Seed_SK_Times _ _ sk _ ts) = diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Mock.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Mock.hs index 8651185e8e3..95e7669e6dc 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Mock.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Mock.hs @@ -2,7 +2,6 @@ module Test.Ouroboros.Storage.ChainDB.Mock (tests) where -import Codec.Serialise (Serialise(encode)) import Control.Exception (Exception) import Control.Monad import Test.QuickCheck @@ -85,4 +84,4 @@ instance Exception InvalidUpdate -------------------------------------------------------------------------------} openDB :: forall s. SimM s (ChainDB (SimM s) TestBlock TestBlock) -openDB = Mock.openDB encode testConfig testInitExtLedger id +openDB = Mock.openDB singleNodeTestConfig testInitExtLedger id diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs index 609187dc043..4cda2ecdda9 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -10,7 +10,6 @@ module Test.Ouroboros.Storage.ChainDB.Model ( tests ) where -import Codec.Serialise (Serialise(encode)) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck @@ -30,26 +29,26 @@ tests = testGroup "Model" [ prop_getBlock_addBlock :: BlockTree -> Permutation -> Property prop_getBlock_addBlock bt p = - M.getBlock (blockHash newBlock) (M.addBlock encode testConfig newBlock model) + M.getBlock (blockHash newBlock) (M.addBlock singleNodeTestConfig newBlock model) === Just newBlock where (newBlock:initBlocks) = permute p $ treeToBlocks bt - model = M.addBlocks encode testConfig initBlocks (M.empty testInitExtLedger) + model = M.addBlocks singleNodeTestConfig initBlocks (M.empty testInitExtLedger) prop_getChain_addChain :: BlockChain -> Property prop_getChain_addChain bc = blockChain bc === M.currentChain model where blocks = chainToBlocks bc - model = M.addBlocks encode testConfig blocks (M.empty testInitExtLedger) + model = M.addBlocks singleNodeTestConfig blocks (M.empty testInitExtLedger) prop_alwaysPickPreferredChain :: BlockTree -> Permutation -> Property prop_alwaysPickPreferredChain bt p = conjoin [ - not $ preferCandidate testConfig (AF.fromChain current) (AF.fromChain candidate) + not $ preferCandidate singleNodeTestConfig (AF.fromChain current) (AF.fromChain candidate) | candidate <- treeToChains bt ] where blocks = permute p $ treeToBlocks bt - model = M.addBlocks encode testConfig blocks (M.empty testInitExtLedger) + model = M.addBlocks singleNodeTestConfig blocks (M.empty testInitExtLedger) current = M.currentChain model diff --git a/ouroboros-consensus/test-util/Test/Util/Orphans/Arbitrary.hs b/ouroboros-consensus/test-util/Test/Util/Orphans/Arbitrary.hs index c511522b08e..a0ae299f65f 100644 --- a/ouroboros-consensus/test-util/Test/Util/Orphans/Arbitrary.hs +++ b/ouroboros-consensus/test-util/Test/Util/Orphans/Arbitrary.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Util.Orphans.Arbitrary @@ -132,7 +133,7 @@ instance DSIGNAlgorithm v => Arbitrary (VerKeyDSIGN v) where arbitrary = deriveVerKeyDSIGN <$> arbitrary shrink = const [] -instance DSIGNAlgorithm v => Arbitrary (SigDSIGN v) where +instance (Signable v Int, DSIGNAlgorithm v) => Arbitrary (SigDSIGN v) where arbitrary = do a <- arbitrary :: Gen Int diff --git a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs index 94575f3e5a4..4cd04897860 100644 --- a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs @@ -23,7 +23,7 @@ module Test.Util.TestBlock ( , treePreferredChain -- * Ledger infrastructure , testInitExtLedger - , testConfig + , singleNodeTestConfig -- * Support for tests , Permutation(..) , permute @@ -44,7 +44,7 @@ import Test.QuickCheck import Ouroboros.Network.Block (ChainHash (..)) import qualified Ouroboros.Network.Block as Block -import Ouroboros.Network.Chain (Chain (..)) +import Ouroboros.Network.Chain (Chain (..), Point) import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Consensus.Crypto.DSIGN @@ -53,6 +53,7 @@ import Ouroboros.Consensus.Node (NodeId (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Util.Condense +import qualified Ouroboros.Consensus.Util.SlotBounded as SB {------------------------------------------------------------------------------- Test infrastructure: test block @@ -111,6 +112,7 @@ type instance BlockProtocol TestBlock = Bft BftMockCrypto instance HasPreHeader TestBlock where type PreHeader TestBlock = () blockPreHeader _ = () + encodePreHeader = const encode instance HasPayload (Bft BftMockCrypto) TestBlock where blockPayload = \cfg tb -> BftPayload { @@ -133,10 +135,12 @@ instance UpdateLedger TestBlock where data LedgerState TestBlock = TestLedger { -- The ledger state simply consists of the last applied block - lastApplied :: ChainHash TestBlock + lastApplied :: (Point TestBlock, ChainHash TestBlock) } deriving (Show) + data LedgerConfig TestBlock = LedgerConfig + data LedgerError TestBlock = -- | The only error possible is that hashes don't line up InvalidHash { @@ -145,23 +149,24 @@ instance UpdateLedger TestBlock where } deriving (Show) - data HeaderState TestBlock = TestHeaderState - - applyLedgerState TestBlock{..} TestLedger{..} = - if tbPrevHash == lastApplied - then return $ TestLedger (BlockHash tbHash) - else throwError $ InvalidHash lastApplied tbPrevHash + applyLedgerBlock _ tb@TestBlock{..} TestLedger{..} = + if tbPrevHash == snd lastApplied + then return $ TestLedger (Chain.blockPoint tb, BlockHash tbHash) + else throwError $ InvalidHash (snd lastApplied) tbPrevHash - getHeaderState _ _ = TestHeaderState - - advanceHeader _ _ _ = return TestHeaderState + applyLedgerHeader _ _ = return + ledgerTipPoint = fst . lastApplied instance ProtocolLedgerView TestBlock where protocolLedgerView _ _ = () + anachronisticProtocolLedgerView _ _ _ = Just $ SB.unbounded () + +instance LedgerConfigView TestBlock where + ledgerConfigView = const LedgerConfig testInitLedger :: LedgerState TestBlock -testInitLedger = TestLedger GenesisHash +testInitLedger = TestLedger (Chain.genesisPoint, GenesisHash) testInitExtLedger :: ExtLedgerState TestBlock testInitExtLedger = ExtLedgerState { @@ -170,8 +175,8 @@ testInitExtLedger = ExtLedgerState { } -- | Trivial test configuration with a single core node -testConfig :: NodeConfig (Bft BftMockCrypto) -testConfig = BftNodeConfig { +singleNodeTestConfig :: NodeConfig (Bft BftMockCrypto) +singleNodeTestConfig = BftNodeConfig { bftParams = BftParams { bftSecurityParam = k , bftNumNodes = 1 } @@ -239,12 +244,11 @@ treeToBlocks = Tree.flatten . blockTree treeToChains :: BlockTree -> [Chain TestBlock] treeToChains = map Chain.fromOldestFirst . allPaths . blockTree -treePreferredChain :: BlockTree -> Chain TestBlock -treePreferredChain = fromMaybe Genesis - . selectUnvalidatedChain - testConfig - Genesis - . treeToChains +treePreferredChain :: NodeConfig (Bft BftMockCrypto) + -> BlockTree -> Chain TestBlock +treePreferredChain cfg = fromMaybe Genesis + . selectUnvalidatedChain cfg Genesis + . treeToChains instance Show BlockTree where show (BlockTree t) = Tree.drawTree (fmap show t) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs index 16a97a22af7..033b9438ca0 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs @@ -8,6 +8,7 @@ module Ouroboros.Network.BlockFetch.Client ( -- * Block fetch protocol client implementation blockFetchClient, + BlockFetchClient, FetchClientContext, TraceFetchClientState, FetchRequest(..), @@ -50,6 +51,11 @@ data BlockFetchProtocolFailure = instance Exception BlockFetchProtocolFailure + +type BlockFetchClient hdr blk m a = + FetchClientContext hdr blk m -> + PeerPipelined (BlockFetch hdr blk) AsClient BFIdle m a + -- | The implementation of the client side of block fetch protocol designed to -- work in conjunction with our fetch logic. -- @@ -57,8 +63,7 @@ blockFetchClient :: forall header block m. (MonadSTM m, MonadTime m, MonadThrow m, HasHeader header, HasHeader block, HeaderHash header ~ HeaderHash block) - => FetchClientContext header block m - -> PeerPipelined (BlockFetch header block) AsClient BFIdle m () + => BlockFetchClient header block m () blockFetchClient FetchClientContext { fetchClientCtxTracer = tracer, fetchClientCtxPolicy = FetchClientPolicy { diff --git a/stack.yaml b/stack.yaml index d2c7740b68a..516b015df13 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,7 +12,7 @@ packages: extra-deps: - git: https://github.com/input-output-hk/iohk-monitoring-framework - commit: cbe7ab32354f3838dc8c95c64109904c8f503347 + commit: f1c4ceef7d7ea6fb4425484c2b19b84048a3549d subdirs: - iohk-monitoring - contra-tracer @@ -24,7 +24,7 @@ extra-deps: - binary/test - git: https://github.com/input-output-hk/cardano-ledger - commit: 684195650722e4d337e90562fddcc5c2b0d17d34 + commit: 761feffb241c2db934c599dc330131ddee034322 subdirs: - . - crypto @@ -38,7 +38,7 @@ extra-deps: - test - git: https://github.com/input-output-hk/cardano-shell - commit: 5db8e79d319a86d48bea4cb70f1e904acae46de4 + commit: 4e9651df29752d1205719028e288ce9e0478a373 - git: https://github.com/input-output-hk/cardano-sl-x509 commit: e8bfc1294e088f90e5ae0b4aedbc82ee46ac5ee4