From 3fd8ab2ac771e19c7181330e1a47b586e32ded2c Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Mon, 27 May 2019 17:29:00 +0200 Subject: [PATCH 01/22] Ledger integration Co-authored-by: Nicholas Clarke Co-authored-by: Thomas Winant --- ouroboros-consensus/demo-playground/CLI.hs | 43 +- .../demo-playground/Mock/TxSubmission.hs | 20 +- ouroboros-consensus/demo-playground/Run.hs | 102 ++- ouroboros-consensus/ouroboros-consensus.cabal | 22 +- .../Ouroboros/Consensus/BlockFetchClient.hs | 24 - .../Ouroboros/Consensus/ChainSyncClient.hs | 280 +++--- .../src/Ouroboros/Consensus/Crypto/DSIGN.hs | 3 + .../Consensus/Crypto/DSIGN/Cardano.hs | 90 ++ .../Ouroboros/Consensus/Crypto/DSIGN/Class.hs | 41 +- .../Ouroboros/Consensus/Crypto/DSIGN/Ed448.hs | 5 +- .../Ouroboros/Consensus/Crypto/DSIGN/Mock.hs | 32 +- .../Consensus/Crypto/DSIGN/RSAPSS.hs | 4 +- .../Ouroboros/Consensus/Crypto/KES/Class.hs | 6 +- .../Ouroboros/Consensus/Crypto/KES/Mock.hs | 8 +- .../Ouroboros/Consensus/Crypto/KES/Simple.hs | 10 +- .../src/Ouroboros/Consensus/Demo.hs | 440 +++++++--- .../Ouroboros/Consensus/Ledger/Abstract.hs | 174 +++- .../src/Ouroboros/Consensus/Ledger/Byron.hs | 822 ++++++++++++++++++ .../src/Ouroboros/Consensus/Ledger/Mock.hs | 137 ++- .../src/Ouroboros/Consensus/Mempool/API.hs | 21 +- .../src/Ouroboros/Consensus/Mempool/Impl.hs | 53 +- .../src/Ouroboros/Consensus/Node.hs | 27 +- .../Ouroboros/Consensus/Protocol/Abstract.hs | 28 +- .../src/Ouroboros/Consensus/Protocol/BFT.hs | 23 +- .../Consensus/Protocol/ExtNodeConfig.hs | 2 + .../Consensus/Protocol/LeaderSchedule.hs | 1 + .../Consensus/Protocol/ModChainSel.hs | 2 + .../src/Ouroboros/Consensus/Protocol/PBFT.hs | 137 +-- .../src/Ouroboros/Consensus/Protocol/Praos.hs | 36 +- .../src/Ouroboros/Consensus/Protocol/Test.hs | 2 + .../src/Ouroboros/Consensus/Util/CBOR.hs | 40 +- .../src/Ouroboros/Storage/ChainDB/Mock.hs | 2 + .../src/Ouroboros/Storage/ChainDB/Model.hs | 24 +- .../Ouroboros/Storage/LedgerDB/InMemory.hs | 10 +- .../Test/Consensus/ChainSyncClient.hs | 18 +- .../test-consensus/Test/Dynamic/General.hs | 19 +- .../Test/Dynamic/LeaderSchedule.hs | 3 +- .../test-consensus/Test/Dynamic/Network.hs | 28 +- .../test-consensus/Test/Dynamic/PBFT.hs | 9 +- .../test-consensus/Test/Dynamic/Praos.hs | 9 +- .../test-consensus/Test/Dynamic/Util.hs | 54 +- .../test-crypto/Test/Crypto/DSIGN.hs | 17 +- .../test-crypto/Test/Crypto/KES.hs | 17 +- .../Test/Ouroboros/Storage/ChainDB/Mock.hs | 4 +- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 12 +- .../test-util/Test/Util/Orphans/Arbitrary.hs | 3 +- .../test-util/Test/Util/TestBlock.hs | 44 +- .../Ouroboros/Network/BlockFetch/Client.hs | 9 +- 48 files changed, 2278 insertions(+), 639 deletions(-) delete mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/BlockFetchClient.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs diff --git a/ouroboros-consensus/demo-playground/CLI.hs b/ouroboros-consensus/demo-playground/CLI.hs index 6bb87190bc0..a8956620184 100644 --- a/ouroboros-consensus/demo-playground/CLI.hs +++ b/ouroboros-consensus/demo-playground/CLI.hs @@ -2,6 +2,8 @@ module CLI ( CLI(..) , TopologyInfo(..) , Command(..) + , Protocol(..) + , fromProtocol , parseCLI -- * Handy re-exports , execParser @@ -25,6 +27,8 @@ import Ouroboros.Consensus.Util import Mock.TxSubmission (command', parseMockTx) import Topology (TopologyInfo (..)) +import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy + data CLI = CLI { systemStart :: SystemStart , slotDuration :: SlotLength @@ -32,9 +36,30 @@ data CLI = CLI { } data Command = - SimpleNode TopologyInfo (Some DemoProtocol) + SimpleNode TopologyInfo Protocol | TxSubmitter TopologyInfo Mock.Tx +data Protocol = + BFT + | Praos + | MockPBFT + | RealPBFT + +fromProtocol :: Protocol -> IO (Some DemoProtocol) +fromProtocol BFT = + return $ Some $ DemoBFT defaultSecurityParam +fromProtocol Praos = + return $ Some $ DemoPraos defaultDemoPraosParams +fromProtocol MockPBFT = + return $ Some $ DemoMockPBFT (defaultDemoPBftParams genesisConfig) + where + -- TODO: This is nasty + genesisConfig = error "genesis config not needed when using mock ledger" +fromProtocol RealPBFT = do + return $ Some $ DemoRealPBFT (defaultDemoPBftParams genesisConfig) + where + genesisConfig = Dummy.dummyConfig + parseCLI :: Parser CLI parseCLI = CLI <$> parseSystemStart @@ -57,19 +82,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..aea2b3eb1c3 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 p + => Tracer IO String + -> NodeKernel IO NodeId (Block p) (Header p) -> 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 p + => Tracer IO String -> NodeId - -> NodeKernel IO NodeId (Mock.SimpleBlock p c) (Mock.SimpleHeader p c) + -> NodeKernel IO NodeId (Block p) (Header p) -> 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..73026d703a7 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,7 +32,6 @@ 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 @@ -53,15 +56,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 + Some p <- fromProtocol protocol + case runDemo p of + Dict -> 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 +handleSimpleNode :: forall p. RunDemo p => DemoProtocol p -> CLI -> TopologyInfo -> IO () handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do putStrLn $ "System started at " <> show systemStart @@ -77,10 +80,8 @@ 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 @@ -88,29 +89,32 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do 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 (Header p) + 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 (Block p) (Header p) <- ChainDB.openDB + (demoEncodePreHeader pInfoConfig) pInfoConfig pInfoInitLedger + demoGetHeader btime <- realBlockchainTime registry slotDuration systemStart let tracer = contramap ((show myNodeId <> " | ") <>) stdoutTracer nodeParams = NodeParams - { tracer + { encoder = demoEncodePreHeader pInfoConfig + , tracer = tracer , threadRegistry = registry , maxClockSkew = ClockSkew 1 , cfg = pInfoConfig @@ -118,9 +122,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 +133,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 @@ -156,35 +161,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 p + -> NodeKernel IO NodeId (Block p) (Header p) -> 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 pInfoConfig) + (demoDecodeBlock pInfoConfig) + (demoDecodeHeaderHash pInfoConfig) , ncWithChan = NamedPipe.withPipeChannel "block-fetch" direction } - - addDownstream' :: NodeKernel IO NodeId (Block p) (Header p) + addDownstream' :: ProtocolInfo p + -> NodeKernel IO NodeId (Block p) (Header p) -> 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 pInfoConfig) + (demoDecodeBlock pInfoConfig) + (demoDecodeHeaderHash pInfoConfig) , ncWithChan = NamedPipe.withPipeChannel "block-fetch" direction } + + encodePoint' :: ProtocolInfo p -> Point (Header p) -> Encoding + encodePoint' ProtocolInfo{..} = + Block.encodePoint $ Block.encodeChainHash (demoEncodeHeaderHash pInfoConfig) + + decodePoint' :: forall s. ProtocolInfo p -> Decoder s (Point (Header p)) + decodePoint' ProtocolInfo{..} = + Block.decodePoint $ Block.decodeChainHash (demoDecodeHeaderHash pInfoConfig) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index a7bf00e27b6..bbe18d362ea 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,7 @@ library Ouroboros.Consensus.Crypto.VRF.Simple Ouroboros.Consensus.Demo Ouroboros.Consensus.Ledger.Abstract + Ouroboros.Consensus.Ledger.Byron Ouroboros.Consensus.Ledger.Mock Ouroboros.Consensus.Mempool Ouroboros.Consensus.Mempool.API @@ -162,18 +163,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 +218,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..d25913bd4f7 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 ( @@ -15,12 +16,12 @@ module Ouroboros.Consensus.ChainSyncClient ( , CandidateState (..) ) where +import Codec.CBOR.Encoding (Encoding) import Control.Monad 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 +32,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) import Ouroboros.Network.Protocol.ChainSync.Client import Ouroboros.Consensus.BlockchainTime @@ -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,16 +87,20 @@ 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) +data CandidateState hdr = CandidateState + { candidateChain :: !(AnchoredFragment hdr) + , candidateChainState :: !(ChainState (BlockProtocol hdr)) -- ^ 'HeaderState' corresponding to the tip (most recent block) of the -- 'candidateChain'. } @@ -111,22 +116,26 @@ 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 + , SupportedPreHeader (BlockProtocol hdr) (PreHeader hdr) ) => Tracer m String -> NodeConfig (BlockProtocol hdr) + -> (PreHeader hdr -> Encoding) -> BlockchainTime m -> 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 -chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain +chainSyncClient tracer cfg toEnc btime (ClockSkew maxSkew) getCurrentChain getCurrentLedger varCandidates up = ChainSyncClient initialise where @@ -143,7 +152,7 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain -- We also validate the headers of a candidate chain by advancing the -- 'HeaderState' 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,6 +160,22 @@ 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. -- + -- 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 #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. @@ -178,12 +203,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) @@ -207,33 +232,29 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain } -- One of the points we sent intersected our chain - intersectImproved :: TVar m (CandidateState blk hdr) + 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' + (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' + , candidateChainState = candidateChainState' } return $ requestNext varCandidate @@ -245,12 +266,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 @@ -264,121 +284,161 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain -- Get the 'HeaderState' at genesis (0). let candidateChain' = Empty genesisPoint - candidateHeaderState' = - getHeaderStateFor curLedger candidateChain candidateChain' + + candidateChainState' <- case rewindChainState cfg curChainState (SlotNo 0) 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 atSlot (pointSlot hdrPoint) view 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 toEnc 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' + , 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). + Nothing -> disconnect $ + InvalidRollBack intersection theirHead + writeTVar varCandidate CandidateState { candidateChain = candidateChain' - , candidateHeaderState = candidateHeaderState' + , 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..41cd942a189 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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.Reflection (Given(..)) +import GHC.Generics (Generic) + +import Ouroboros.Consensus.Crypto.DSIGN.Class +import Ouroboros.Consensus.Util.Condense + + +class HasSignTag a where + signTag :: a -> SignTag + +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 (signTag a) sk (toEnc a) + + verifyDSIGN toEnc (VerKeyCardanoDSIGN vk) a (SigCardanoDSIGN sig) = + if verifySignature toEnc given (signTag 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..d368e200f3a 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 #-} @@ -8,18 +10,25 @@ module Ouroboros.Consensus.Crypto.DSIGN.Class ( DSIGNAlgorithm (..) , SignedDSIGN (..) + , Empty , signedDSIGN , verifySignedDSIGN , encodeSignedDSIGN , 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.Condense +class Empty a +instance Empty a + class ( Show (VerKeyDSIGN v) , Ord (VerKeyDSIGN v) , Show (SignKeyDSIGN v) @@ -34,17 +43,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 +73,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..0b24d16258c 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Class.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Class.hs @@ -50,7 +50,8 @@ class ( Show (VerKeyKES v) -> a -> SignKeyKES v -> m (Maybe (SigKES v, SignKeyKES v)) - verifyKES :: (a -> Encoding) -> VerKeyKES v -> Natural -> a -> SigKES v -> Bool + verifyKES :: (a -> Encoding) + -> VerKeyKES v -> Natural -> a -> SigKES v -> Either String () newtype SignedKES v a = SignedKES {getSig :: SigKES v} deriving (Generic) @@ -71,5 +72,6 @@ signedKES toEnc time a key = do Just (sig, key') -> Just (SignedKES sig, key') verifySignedKES :: (KESAlgorithm v) - => (a -> Encoding) -> VerKeyKES v -> Natural -> a -> SignedKES v a -> Bool + => (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..37868a76d91 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Simple.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Simple.hs @@ -5,6 +5,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Mock key evolving signatures. module Ouroboros.Consensus.Crypto.KES.Simple @@ -26,7 +27,12 @@ import Ouroboros.Consensus.Util.Condense data SimpleKES d -instance DSIGNAlgorithm d => KESAlgorithm (SimpleKES d) where +instance ( DSIGNAlgorithm d + -- TODO We currently don't support other 'Signable' constraints for + -- KES. We could, but it's more stuff to do. So for the moment we fix + -- this here. + , Signable d ~ Empty + ) => KESAlgorithm (SimpleKES d) where newtype VerKeyKES (SimpleKES d) = VerKeySimpleKES (Vector (VerKeyDSIGN d)) deriving Generic @@ -61,7 +67,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..c66776e8343 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs @@ -1,27 +1,34 @@ -{-# 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 + , DemoMockPBFT + , DemoRealPBFT , Block , Header , NumCoreNodes(..) , ProtocolInfo(..) , protocolInfo - , DemoProtocolConstraints - , demoProtocolConstraints + , RunDemo(..) + , runDemo -- * Support for runnig the demos , defaultSecurityParam , defaultDemoPraosParams @@ -30,16 +37,33 @@ module Ouroboros.Consensus.Demo ( , HasCreator(..) ) where -import Codec.Serialise (Serialise) +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) +import qualified Codec.Serialise as Serialise import Control.Monad.Except +import Crypto.Random (MonadRandom) +import qualified Data.Bimap as Bimap +import Data.Coerce import Data.Either (fromRight) 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, StandardHash) +import Ouroboros.Network.BlockFetch (SizeInBytes) +import Ouroboros.Network.Chain (genesisPoint) import Ouroboros.Consensus.Crypto.DSIGN import Ouroboros.Consensus.Crypto.DSIGN.Mock (verKeyIdFromSigned) @@ -47,7 +71,10 @@ 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 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,27 +86,46 @@ 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 ByronDemoConfig (PBft PBftCardanoCrypto) -- | Consensus protocol to use data DemoProtocol p where + -- | Run BFT against the mock ledger DemoBFT :: SecurityParam -> DemoProtocol DemoBFT - DemoPBFT :: PBftParams -> DemoProtocol DemoPBFT + + -- | Run Praos against the mock ledger DemoPraos :: PraosParams -> DemoProtocol DemoPraos + + -- | Run Praos against the mock ledger but with an explicit leader schedule DemoLeaderSchedule :: LeaderSchedule -> PraosParams -> DemoProtocol DemoLeaderSchedule --- | Our 'Block' type stays the same. -type Block p = SimpleBlock p SimpleBlockMockCrypto + -- | Run PBFT against the mock ledger + DemoMockPBFT :: PBftParams -> DemoProtocol DemoMockPBFT + + -- | Run PBFT against the real ledger + DemoRealPBFT :: PBftParams -> DemoProtocol DemoRealPBFT + +type family Block p = b | b -> p where + Block DemoRealPBFT = ByronBlock ByronDemoConfig + + -- Demos using mock ledger/block + Block p = SimpleBlock p SimpleBlockMockCrypto + +type family Header p :: * where + Header DemoRealPBFT = ByronHeader ByronDemoConfig --- | Our 'Header' type stays the same. -type Header p = SimpleHeader p SimpleBlockMockCrypto + -- Demos using mock ledger/block + Header p = SimpleHeader p SimpleBlockMockCrypto -- | Data required to run the specified protocol. data ProtocolInfo p = ProtocolInfo { @@ -89,23 +135,6 @@ data ProtocolInfo p = ProtocolInfo { , pInfoInitState :: NodeState p } -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) @@ -129,27 +158,7 @@ protocolInfo (DemoBFT securityParam) (NumCoreNodes numCoreNodes) (CoreNodeId nid , 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 ) - , pInfoInitState = () - } - where - addrDist :: AddrDist + addrDist :: Mock.AddrDist addrDist = mkAddrDist numCoreNodes protocolInfo (DemoPraos params) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = ProtocolInfo { @@ -175,7 +184,7 @@ protocolInfo (DemoPraos params) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = ) } where - addrDist :: AddrDist + addrDist :: Mock.AddrDist addrDist = mkAddrDist numCoreNodes verKeys :: IntMap (VerKeyKES MockKES, VerKeyVRF MockVRF) @@ -211,14 +220,74 @@ protocolInfo (DemoLeaderSchedule schedule params) 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 (genesisLedgerState addrDist) Seq.empty + , pInfoInitState = () + } + where + addrDist :: Mock.AddrDist + addrDist = mkAddrDist numCoreNodes -{- - data NodeConfig (WithLeaderSchedule p) = WLSNodeConfig - { lsNodeConfigWithLeaderSchedule :: LeaderSchedule - , lsNodeConfigP :: NodeConfig p - , lsNodeConfigNodeId :: Int - } - -} +protocolInfo (DemoRealPBFT params) + (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 (mkKey nid)) + , pbftVerKey = VerKeyCardanoDSIGN (fst (mkKey nid)) + } + , encNodeConfigExt = ByronDemoConfig { + pbftCoreNodes = Bimap.fromList [ + (fst (mkKey n), CoreNodeId n) + | n <- [0 .. numCoreNodes] + ] + , pbftProtocolMagic = Cardano.Genesis.configProtocolMagic gc + , pbftProtocolVersion = Cardano.Update.ProtocolVersion 3 1 4 + , pbftSoftwareVersion = Cardano.Update.SoftwareVersion (Cardano.Update.ApplicationName "harry the hamster") 1 + , 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 + gc = pbftGenesisConfig params + initState :: Cardano.Block.ChainValidationState + Right initState = runExcept $ + Cardano.Block.initialChainValidationState (pbftGenesisConfig params) + + mkKey :: Int -> (Cardano.VerificationKey, Cardano.SigningKey) + mkKey n = (\x -> (Cardano.KeyGen.toVerification x, x)) . (!! n) + . Cardano.Genesis.gsRichSecrets . fromJust $ Cardano.Genesis.configGeneratedSecrets gc {------------------------------------------------------------------------------- Support for running the demos @@ -235,12 +304,13 @@ defaultDemoPraosParams = PraosParams { , praosLifetimeKES = 1000000 } -defaultDemoPBftParams :: PBftParams -defaultDemoPBftParams = PBftParams { +defaultDemoPBftParams :: Cardano.Genesis.Config -> PBftParams +defaultDemoPBftParams genesisConfig = PBftParams { pbftSecurityParam = defaultSecurityParam , pbftNumNodes = nn , pbftSignatureWindow = fromIntegral $ nn * 10 , pbftSignatureThreshold = (1.0 / fromIntegral nn) + 0.1 + , pbftGenesisConfig = genesisConfig } where nn = 3 @@ -256,61 +326,217 @@ enumCoreNodes (NumCoreNodes numNodes) = [ CoreNodeId n -- | Construct address to node ID mapping mkAddrDist :: Int -- ^ Number of nodes - -> AddrDist + -> Mock.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] +genesisTx :: Mock.AddrDist -> Mock.Tx +genesisTx addrDist = Mock.Tx mempty [(addr, 1000) | addr <- Map.keys addrDist] -genesisUtxo :: AddrDist -> Utxo +genesisUtxo :: Mock.AddrDist -> Mock.Utxo genesisUtxo addrDist = fromRight (error "genesisLedger: invalid genesis tx") $ - runExcept (utxo (genesisTx addrDist)) + runExcept (Mock.utxo (genesisTx addrDist)) -genesisLedgerState :: AddrDist -> LedgerState (SimpleBlock p c) -genesisLedgerState addrDist = SimpleLedgerState { +genesisLedgerState :: Mock.AddrDist -> LedgerState (SimpleBlock p c) +genesisLedgerState addrDist = Mock.SimpleLedgerState { slsUtxo = genesisUtxo addrDist , slsConfirmed = Set.singleton (hash (genesisTx addrDist)) + , slsTip = genesisPoint } -- | Genesis stake distribution -genesisStakeDist :: AddrDist -> StakeDist +genesisStakeDist :: Mock.AddrDist -> StakeDist genesisStakeDist addrDist = - relativeStakes (totalStakes addrDist (genesisUtxo addrDist)) + Mock.relativeStakes (Mock.totalStakes addrDist (genesisUtxo addrDist)) {------------------------------------------------------------------------------- Who created a block? -------------------------------------------------------------------------------} -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 +class HasCreator p where + getCreator :: NodeConfig p -> Block p -> CoreNodeId + +instance HasCreator DemoBFT where + getCreator _ = CoreNodeId + . verKeyIdFromSigned + . bftSignature + . Mock.headerOuroboros + . Mock.simpleHeader + +instance HasCreator DemoPraos where + getCreator _ = praosCreator + . praosExtraFields + . encPayloadP + . Mock.headerOuroboros + . Mock.simpleHeader + +instance HasCreator DemoLeaderSchedule where + getCreator _ = getWLSPayload + . Mock.headerOuroboros + . Mock.simpleHeader + +instance HasCreator DemoMockPBFT where + getCreator _ = CoreNodeId + . verKeyIdFromSigned + . pbftSignature + . encPayloadP + . Mock.headerOuroboros + . Mock.simpleHeader + +instance HasCreator DemoRealPBFT where + getCreator (EncNodeConfig _ ByronDemoConfig{..}) (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 +-------------------------------------------------------------------------------} + +-- | The protocol @p@ uses simple (mock) blocks and headers +type IsSimple p = + ( Block p ~ SimpleBlock p SimpleBlockMockCrypto + , Header p ~ SimpleHeader p SimpleBlockMockCrypto + , SupportedPreHeader p ~ Empty + , Serialise.Serialise (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) + ) + +class ( OuroborosTag p + , ProtocolLedgerView (Block p) + , HasCreator p + , Condense (Payload p (PreHeader (Block p))) + , Eq (Payload p (PreHeader (Block p))) + , Show (Payload p (PreHeader (Block p))) + , BlockProtocol (Block p) ~ p + , BlockProtocol (Header p) ~ p + , HeaderHash (Block p) ~ HeaderHash (Header p) + , StandardHash (Header p) + , HasHeader (Header p) + , LedgerConfigView (Block p) + , SupportedBlock (BlockProtocol (Header p)) (Header p) + , SupportedPreHeader p (PreHeader (Block p)) + , PreHeader (Block p) ~ PreHeader (Header p) + , Condense (Block p) + , Condense [Block p] + , Condense (Header p) + , Condense (ChainHash (Header p)) + , ApplyTx (Block p) + , Show (Block p) + , Show (Header p) + ) => RunDemo p where + + demoForgeBlock :: (HasNodeState p m, MonadRandom m) + => NodeConfig p + -> SlotNo -- ^ Current slot + -> BlockNo -- ^ Current block number + -> ChainHash (Header p) -- ^ Previous hash + -> [GenTx (Block p)] -- ^ Txs to add in the block + -> IsLeader p + -> m (Block p) + default demoForgeBlock :: IsSimple p + => (HasNodeState p m, MonadRandom m) + => NodeConfig p + -> SlotNo -- ^ Current slot + -> BlockNo -- ^ Current block number + -> ChainHash (Header p) -- ^ Previous hash + -> [GenTx (Block p)] -- ^ Txs to add in the block + -> IsLeader p + -> m (Block p) + + demoGetHeader :: Block p -> Header p + default demoGetHeader :: IsSimple p => Block p -> Header p + + -- We provide context for the encoders and decoders in case they need access + -- to stuff like "number of slots in an epoch" + + demoEncodeHeader :: NodeConfig p -> Header p -> Encoding + default demoEncodeHeader :: IsSimple p => NodeConfig p -> Header p -> Encoding + + demoEncodeHeaderHash :: NodeConfig p -> HeaderHash (Header p) -> Encoding + default demoEncodeHeaderHash :: IsSimple p => NodeConfig p -> HeaderHash (Header p) -> Encoding + + demoEncodePreHeader :: NodeConfig p -> PreHeader (Block p) -> Encoding + default demoEncodePreHeader :: IsSimple p => NodeConfig p -> PreHeader (Block p) -> Encoding + + demoEncodeBlock :: NodeConfig p -> Block p -> Encoding + default demoEncodeBlock :: IsSimple p => NodeConfig p -> Block p -> Encoding + + demoDecodeHeader :: forall s. NodeConfig p -> Decoder s (Header p) + default demoDecodeHeader :: IsSimple p => forall s. NodeConfig p -> Decoder s (Header p) + + demoDecodeHeaderHash :: forall s. NodeConfig p -> Decoder s (HeaderHash (Header p)) + default demoDecodeHeaderHash :: IsSimple p => forall s. NodeConfig p -> Decoder s (HeaderHash (Header p)) + + demoDecodeBlock :: forall s. NodeConfig p -> Decoder s (Block p) + default demoDecodeBlock :: IsSimple p => forall s. NodeConfig p -> Decoder s (Block p) + + demoBlockFetchSize :: Header p -> SizeInBytes + default demoBlockFetchSize :: IsSimple p => Header p -> SizeInBytes + + demoBlockMatchesHeader :: Header p -> Block p -> Bool + default demoBlockMatchesHeader :: IsSimple p => Header p -> Block p -> Bool + + -- | 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 p -> Mock.Tx -> GenTx (Block p) + default demoMockTx :: IsSimple p => NodeConfig p -> Mock.Tx -> GenTx (Block p) + + demoForgeBlock = Mock.forgeSimpleBlock + demoGetHeader = Mock.simpleHeader + demoEncodeHeader = const Serialise.encode + demoEncodeHeaderHash = const Serialise.encode + demoEncodePreHeader = const Serialise.encode + demoEncodeBlock = const Serialise.encode + demoDecodeHeader = const Serialise.decode + demoDecodeHeaderHash = const Serialise.decode + demoDecodeBlock = const Serialise.decode + demoBlockFetchSize = Mock.headerBlockSize . Mock.headerPreHeader + demoBlockMatchesHeader = Mock.blockMatchesHeader + demoMockTx = \_ -> id + +runDemo :: DemoProtocol p -> Dict (RunDemo p) +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 + +-- Protocols using SimpleBlock +instance RunDemo DemoBFT +instance RunDemo DemoPraos +instance RunDemo DemoLeaderSchedule +instance RunDemo DemoMockPBFT + +instance ( Given Cardano.ProtocolMagicId + , Given Cardano.Slot.EpochSlots + , Given Cardano.Block.HeaderHash + ) => RunDemo DemoRealPBFT where + + demoForgeBlock = forgeByronDemoBlock + demoGetHeader = byronHeader + demoEncodeHeader = encodeByronDemoHeader + demoEncodeHeaderHash = encodeByronDemoHeaderHash + demoEncodePreHeader = encodeByronDemoPreHeader + demoEncodeBlock = encodeByronDemoBlock + demoDecodeHeader = decodeByronDemoHeader + demoDecodeHeaderHash = decodeByronDemoHeaderHash + demoDecodeBlock = decodeByronDemoBlock + demoBlockFetchSize = const 2000 -- TODO + demoBlockMatchesHeader _hdr _blk = True -- TODO + demoMockTx = elaborateByronTx diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs index 8d34f249663..54cf047dd16 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -10,10 +11,15 @@ -- | Interface to the ledger layer module Ouroboros.Consensus.Ledger.Abstract ( + SlotBounded(sbLower, sbUpper) + , slotUnbounded + , atSlot + , slotBounded -- * Interaction with the ledger layer - UpdateLedger(..) + , UpdateLedger(..) , BlockProtocol , ProtocolLedgerView(..) + , LedgerConfigView(..) -- * Extended ledger state , ExtLedgerState(..) , ExtValidationError(..) @@ -30,13 +36,35 @@ import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding) import Control.Monad.Except -import Data.Word (Word64) - import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util (repeatedlyM) -import Ouroboros.Network.Block (HasHeader (..)) +import Ouroboros.Network.Block (HasHeader (..), Point, SlotNo) import Ouroboros.Network.Chain (Chain, toOldestFirst) +import GHC.Stack + +-- | 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. +slotBounded :: SlotNo -> SlotNo -> a -> SlotBounded a +slotBounded = SlotBounded + +slotUnbounded :: a -> SlotBounded a +slotUnbounded = SlotBounded minBound maxBound + +atSlot :: SlotNo -> SlotBounded a -> Maybe a +atSlot slot sb = + if (slot <= sbUpper sb && slot >= sbLower sb) + then Just $ sbContent sb + else Nothing + {------------------------------------------------------------------------------- Interaction with the ledger layer -------------------------------------------------------------------------------} @@ -47,45 +75,37 @@ 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 + data family LedgerConfig b :: * + + -- | Apply a block header to the ledger state. + -- + -- Used in 'applyExtLedgerState' to update the ledger state in 3 steps: -- - -- 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 + -- 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: 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 +120,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 -------------------------------------------------------------------------------} @@ -121,7 +192,11 @@ data ExtValidationError b = deriving instance ProtocolLedgerView b => Show (ExtValidationError b) -applyExtLedgerState :: ProtocolLedgerView b +applyExtLedgerState :: ( LedgerConfigView b + , ProtocolLedgerView b + , SupportedPreHeader (BlockProtocol b) (PreHeader b) + , HasCallStack + ) => (PreHeader b -> Encoding) -- Serialiser for the preheader -> NodeConfig (BlockProtocol b) -> b @@ -129,7 +204,7 @@ applyExtLedgerState :: ProtocolLedgerView b -> Except (ExtValidationError b) (ExtLedgerState b) applyExtLedgerState toEnc cfg b ExtLedgerState{..} = do ledgerState' <- withExcept ExtValidationErrorLedger $ - applyLedgerState b ledgerState + applyLedgerHeader (ledgerConfigView cfg) b ledgerState ouroborosChainState' <- withExcept ExtValidationErrorOuroboros $ applyChainState toEnc @@ -137,9 +212,15 @@ applyExtLedgerState toEnc cfg b ExtLedgerState{..} = do (protocolLedgerView cfg ledgerState') b ouroborosChainState - return $ ExtLedgerState ledgerState' ouroborosChainState' + ledgerState'' <- withExcept ExtValidationErrorLedger $ + applyLedgerBlock (ledgerConfigView cfg) b ledgerState' + return $ ExtLedgerState ledgerState'' ouroborosChainState' -foldExtLedgerState :: ProtocolLedgerView b +foldExtLedgerState :: ( LedgerConfigView b + , ProtocolLedgerView b + , SupportedPreHeader (BlockProtocol b) (PreHeader b) + , HasCallStack + ) => (PreHeader b -> Encoding) -- Serialiser for the preheader -> NodeConfig (BlockProtocol b) -> [b] -- ^ Blocks to apply, oldest first @@ -148,7 +229,11 @@ foldExtLedgerState :: ProtocolLedgerView b foldExtLedgerState toEnc = repeatedlyM . applyExtLedgerState toEnc -- TODO: This should check stuff like backpointers also -chainExtLedgerState :: ProtocolLedgerView b +chainExtLedgerState :: ( LedgerConfigView b + , ProtocolLedgerView b + , SupportedPreHeader (BlockProtocol b) (PreHeader b) + , HasCallStack + ) => (PreHeader b -> Encoding) -- Serialiser for the preheader -> NodeConfig (BlockProtocol b) -> Chain b @@ -157,7 +242,10 @@ chainExtLedgerState :: ProtocolLedgerView b chainExtLedgerState toEnc cfg = foldExtLedgerState toEnc cfg . toOldestFirst -- | Validation of an entire chain -verifyChain :: ProtocolLedgerView b +verifyChain :: ( LedgerConfigView b + , ProtocolLedgerView b + , SupportedPreHeader (BlockProtocol b) (PreHeader b) + ) => (PreHeader b -> Encoding) -- Serialiser for the preheader -> NodeConfig (BlockProtocol b) -> ExtLedgerState b 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..d3a115a6be1 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -0,0 +1,822 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_ghc -fno-warn-orphans #-} + +module Ouroboros.Consensus.Ledger.Byron where + +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) +import qualified Codec.CBOR.Encoding as Encoding +import qualified Codec.CBOR.Read as CBOR +import qualified Codec.CBOR.Write as CBOR +import Control.Monad.Except +import Crypto.Random (MonadRandom) +import Data.Bifunctor (bimap) +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import qualified Data.ByteString.Lazy as Lazy +import Data.Coerce +import Data.FingerTree (Measured (..)) +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.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Typeable +import qualified Data.Vector as V +import Data.Word +import Formatting + +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 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 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.Update.Validation.Interface as CC.UPI +import qualified Cardano.Chain.UTxO as CC.UTxO +import qualified Cardano.Crypto as Crypto +import Cardano.Prelude (panic) + +import Ouroboros.Network.Block + +import Ouroboros.Consensus.Crypto.DSIGN +import Ouroboros.Consensus.Crypto.Hash +import Ouroboros.Consensus.Ledger.Abstract +import qualified Ouroboros.Consensus.Ledger.Mock as Mock +import Ouroboros.Consensus.Mempool.API +import Ouroboros.Consensus.Node (CoreNodeId) +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.ExtNodeConfig +import Ouroboros.Consensus.Protocol.PBFT +import Ouroboros.Consensus.Util.Condense + +import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy + +-- | 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) + +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 + +newtype ByronHeader cfg = ByronHeader { unByronHeader :: CC.Block.AHeader ByteString } + deriving (Eq, Show) + +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 + +byronHeader :: ByronBlock cfg -> ByronHeader cfg +byronHeader (ByronBlock b) = ByronHeader (CC.Block.blockHeader b) + +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 + +convertSlot :: CC.Slot.FlatSlotId -> SlotNo +convertSlot = coerce + +convertFlatSlotId :: SlotNo -> CC.Slot.FlatSlotId +convertFlatSlotId = coerce + +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 should distinguish the genesis hash + -- TODO: doing this correctly will require using the epoch boundary block + 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 StandardHash (ByronBlock cfg) +instance StandardHash (ByronHeader cfg) + +instance (Given Crypto.ProtocolMagicId, Typeable cfg) => LedgerConfigView (ByronBlock cfg) where + ledgerConfigView EncNodeConfig{..} = + ByronLedgerConfig $ pbftGenesisConfig (pbftParams encNodeConfigP) + +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 Genesis.Config + + applyLedgerBlock (ByronLedgerConfig cfg) (ByronBlock block) (ByronLedgerState state snapshots) + = mapExcept (bimap ByronLedgerError id) $ 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' = trimSnapshots $ + if (CC.Block.cvsDelegationState state' == CC.Block.cvsDelegationState state) + then snapshots + else + let startOfSnapshot = case snapshots of + _ Seq.:|> a -> sbUpper a + Seq.Empty -> SlotNo 0 + in snapshots Seq.|> slotBounded startOfSnapshot (convertSlot $ CC.Block.blockSlot block) state' + + pure $ ByronLedgerState state' 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 $ Genesis.configProtocolMagic cfg + , CC.Block.k = Genesis.configK cfg + , CC.Block.numGenKeys + , CC.Block.protocolParameters = CC.UPI.adoptedProtocolParameters . CC.Block.cvsUpdateState $ state + , CC.Block.currentEpoch = CC.Slot.slotNumberEpoch (Genesis.configEpochSlots cfg) (CC.Block.blockSlot block) + } + numGenKeys :: Word8 + numGenKeys = + case length (Genesis.unGenesisWStakeholders $ Genesis.configBootStakeholders cfg) of + n + | n > fromIntegral (maxBound :: Word8) -> panic + "updateBody: Too many genesis keys" + | otherwise -> fromIntegral n + fixPM (Crypto.AProtocolMagic a b) = Crypto.AProtocolMagic (reAnnotate a) b + trimSnapshots = Seq.dropWhileL (\ss -> sbUpper ss + < convertSlot (CC.Block.blockSlot block) - 2*(coerce $ Genesis.configK cfg)) + + 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) + pure $ 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 $ Genesis.configProtocolMagicId cfg + , CC.Block.k = Genesis.configK cfg + , CC.Block.numGenKeys + , CC.Block.delegationMap + , CC.Block.lastSlot = CC.Block.cvsLastSlot state + } + numGenKeys :: Word8 + numGenKeys = + case length (Genesis.unGenesisWStakeholders $ Genesis.configBootStakeholders cfg) of + n + | n > fromIntegral (maxBound :: Word8) -> panic + "updateBody: Too many genesis keys" + | otherwise -> fromIntegral n + + 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 + } + +{------------------------------------------------------------------------------- + Support for PBFT consensus algorithm +-------------------------------------------------------------------------------} + +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 + +-- 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 + +-- 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 + +-- | Override the delegation map from the ledger view +-- +-- This is to work around a bug in cardano-ledger +-- +reconstructDelegationMap :: Bimap CC.Common.StakeholderId CC.Common.StakeholderId +reconstructDelegationMap = + go $ Genesis.gdHeavyDelegation Dummy.dummyGenesisData + where + go :: Genesis.GenesisDelegation + -> Bimap CC.Common.StakeholderId CC.Common.StakeholderId + go = Bimap.fromList . map go' . Map.toList . Genesis.unGenesisDelegation + + go' :: (CC.Common.StakeholderId, Delegation.Certificate) + -> (CC.Common.StakeholderId, CC.Common.StakeholderId) + go' (from, to) = + if issuer /= from + then error "reconstructDelegationMap: unexpected issuer" + else (from, delegate) + where + issuer, delegate :: CC.Common.StakeholderId + issuer = CC.Common.mkStakeholderId $ Crypto.pskIssuerVK to + delegate = CC.Common.mkStakeholderId $ Crypto.pskDelegateVK to + +instance ( Given Crypto.ProtocolMagicId + , Given CC.Slot.EpochSlots + , Given CC.Block.HeaderHash + , Typeable cfg + ) => ProtocolLedgerView (ByronBlock cfg) where + protocolLedgerView _ns (ByronLedgerState ls _) = PBftLedgerView + -- Delegation map + ( 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 . Delegation.unMap + . V.Interface.delegationMap + . CC.Block.cvsDelegationState <$> sb + -- No snapshot - we could be in the past or in the future + Nothing -> + if slot >= lvLB && slot <= lvUB + then Just $ PBftLedgerView <$> + case Seq.takeWhileL (\sd -> convertSlot (V.Scheduling.sdSlot sd) <= slot) dsScheduled of + Seq.Empty -> -- No updates to apply. So the current ledger state is + -- valid from the end of the last snapshot to the first + -- scheduled update. + slotBounded lb ub dsNow + toApply@(_ Seq.:|> la) -> slotBounded lb (convertSlot . V.Scheduling.sdSlot $ la) + $ foldl (\acc x -> Bimap.insert (V.Scheduling.sdDelegator x) (V.Scheduling.sdDelegate x) acc) dsNow toApply + else 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 + where + SecurityParam paramK = pbftSecurityParam . pbftParams . encNodeConfigP $ cfg + lvUB = SlotNo $ unSlotNo currentSlot + (2 * paramK) + lvLB = SlotNo $ if 2 * paramK > unSlotNo currentSlot then 0 else unSlotNo currentSlot - (2 * paramK) + dsNow = 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 + +class UpdateLedger b => ApplyTx b where + -- | Generalized transaction + -- + -- 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 :: * + + -- | Apply transaction we have not previously seen before + applyTx :: GenTx b + -> LedgerState b + -> Except (LedgerError 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 + -> LedgerState b + -> Except (LedgerError 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 +-------------------------------------------------------------------------------} + +-- | Generalized transactions in Byron +-- +-- TODO: This is still missing the other cases (this shouldn't be a newtype) +-- TODO: Should this use ATxAux instead? +newtype ByronGenTx = ByronTx { unByronTx :: CC.UTxO.ATxAux ByteString } + +instance ApplyTx (ByronBlock cfg) where + type GenTx (ByronBlock cfg) = ByronGenTx + type ApplyTxErr (ByronBlock cfg) = CC.UTxO.UTxOValidationError + + applyTx = applyByronGenTx False + reapplyTx = applyByronGenTx True + + -- TODO: 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 $ "Ouroboros.Consensus.Ledger.Byron.reapplyTxSameState: unexpected error: " ++ show err + Right st' -> st' + +applyByronGenTx :: Bool -- ^ Have we verified this transaction previously? + -> LedgerConfig (ByronBlock cfg) + -> ByronGenTx + -> 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 :: ByronGenTx + -> 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 $ 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 + +{------------------------------------------------------------------------------- + Running Byron in the demo +-------------------------------------------------------------------------------} + +-- Extended configuration we need for the demo +data ByronDemoConfig = ByronDemoConfig { + -- | 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 + + -- | TODO ok? + -- + -- We can use 'CC.Dummy.dummyGenesisHash' for this + , pbftGenesisHash :: Genesis.GenesisHash + , pbftGenesisDlg :: Genesis.GenesisDelegation + , pbftSecrets :: Genesis.GeneratedSecrets + } + +type ByronPayload = + Payload + (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + CC.Block.ToSign + +forgeByronDemoBlock + :: ( HasNodeState_ () m -- @()@ is the @NodeState@ of PBFT + , MonadRandom m + , Given Crypto.ProtocolMagicId + ) + => NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + -> SlotNo -- ^ Current slot + -> BlockNo -- ^ Current block number + -> ChainHash (ByronHeader cfg) -- ^ Previous hash + -> [ByronGenTx] -- ^ Txs to add in the block + -> () -- ^ Leader proof (IsLeader) + -> m (ByronBlock ByronDemoConfig) +forgeByronDemoBlock cfg curSlot curNo prevHash txs () = do + ouroborosPayload <- mkPayload toCBOR cfg () preHeader +-- traceM $ "Forge block: " ++ show (forgeBlock ouroborosPayload) + return $ forgeBlock ouroborosPayload + where + ByronDemoConfig {..} = encNodeConfigExt cfg + + txPayload :: CC.UTxO.TxPayload + txPayload = CC.UTxO.mkTxPayload (map (fmap (const ()) . unByronTx) txs) + + body :: CC.Block.Body + body = CC.Block.ABody { + CC.Block.bodyTxPayload = txPayload + , CC.Block.bodySscPayload = CC.Ssc.SscPayload + , CC.Block.bodyDlgPayload = 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 + } + + forgeBlock :: ByronPayload -> ByronBlock ByronDemoConfig + forgeBlock 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 :: Delegation.Certificate + (headerGenesisKey, dlgCertificate) = case findDelegate of + Just x -> x + Nothing -> error "Issuer is not a valid genesis key delegate." + where + dlgMap = 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 (convertFlatSlotId 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' +elaborateByronTx :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + -> Mock.Tx -> ByronGenTx +elaborateByronTx 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 :: Int + mockOut = case lookup mockAddr (zip ["a", "b", "c", "d"] [0..]) of + Nothing -> error "elaborateByronTx: 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 + + -- TODO: Can we reuse these special "initial balance" addresses? Not sure + 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 (pbftParams (encNodeConfigP 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..] $ + 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 + . toCBORBlockWithoutBoundary 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 +-------------------------------------------------------------------------------} + +encodeByronDemoHeader :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + -> ByronHeader ByronDemoConfig -> Encoding +encodeByronDemoHeader cfg = + CC.Block.toCBORHeader' epochSlots + . fmap (const ()) + . unByronHeader + where + epochSlots = pbftEpochSlots (encNodeConfigExt cfg) + +encodeByronDemoBlock :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + -> ByronBlock ByronDemoConfig -> Encoding +encodeByronDemoBlock cfg = + toCBORBlockWithoutBoundary epochSlots + . fmap (const ()) + . unByronBlock + where + epochSlots = pbftEpochSlots (encNodeConfigExt cfg) + +encodeByronDemoHeaderHash :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + -> HeaderHash (ByronHeader ByronDemoConfig) -> Encoding +encodeByronDemoHeaderHash _cfg = toCBOR + +encodeByronDemoPreHeader :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + -> PreHeader (ByronBlock ByronDemoConfig) -> Encoding +encodeByronDemoPreHeader _cfg = toCBOR + +decodeByronDemoHeader :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + -> Decoder s (ByronHeader ByronDemoConfig) +decodeByronDemoHeader cfg = + fmap (ByronHeader . annotate) $ + CC.Block.fromCBORAHeader epochSlots + where + -- TODO: 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 . fmap (const ()) + + epochSlots = pbftEpochSlots (encNodeConfigExt cfg) + +decodeByronDemoBlock :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + -> Decoder s (ByronBlock ByronDemoConfig) +decodeByronDemoBlock cfg = + fmap (ByronBlock . annotate) $ + CC.Block.fromCBORABlock epochSlots + where + -- TODO: 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 . fmap (const ()) + + epochSlots = pbftEpochSlots (encNodeConfigExt cfg) + +decodeByronDemoHeaderHash :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) + -> Decoder s (HeaderHash (ByronHeader ByronDemoConfig)) +decodeByronDemoHeaderHash _cfg = fromCBOR + +{------------------------------------------------------------------------------- + This should be exported from -ledger +-------------------------------------------------------------------------------} + +toCBORBlockWithoutBoundary :: CC.Slot.EpochSlots -> CC.Block.Block -> Encoding +toCBORBlockWithoutBoundary epochSlots block + = Encoding.encodeListLen 3 + <> CC.Block.toCBORHeader' epochSlots (CC.Block.blockHeader block) + <> toCBOR (CC.Block.blockBody block) + <> (Encoding.encodeListLen 1 <> toCBOR (mempty :: Map Word8 Lazy.ByteString)) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs index 75271558a04..a8efb68775c 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs @@ -31,11 +31,10 @@ module Ouroboros.Consensus.Ledger.Mock ( , SimpleHeader(..) , SimplePreHeader(..) , SimpleBody(..) - , forgeBlock + , forgeSimpleBlock , blockMatchesHeader -- * Updating the Ledger state , LedgerState(..) - , HeaderState(..) , AddrDist , relativeStakes , totalStakes @@ -61,6 +60,7 @@ import GHC.Generics (Generic) import Ouroboros.Network.Block import Ouroboros.Network.Chain (Chain, toOldestFirst) +import Ouroboros.Consensus.Crypto.DSIGN.Class (Empty) import Ouroboros.Consensus.Crypto.Hash.Class import Ouroboros.Consensus.Crypto.Hash.MD5 (MD5) import Ouroboros.Consensus.Crypto.Hash.Short (ShortHash) @@ -316,21 +316,23 @@ 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 +forgeSimpleBlock :: forall m p c. + ( HasNodeState p m + , MonadRandom m + , OuroborosTag p + , SimpleBlockCrypto c + , Serialise (Payload p (SimplePreHeader p c)) + -- TODO Decide whether we want to fix this constraint here. + , SupportedPreHeader p ~ Empty + ) + => 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) +forgeSimpleBlock cfg curSlot curNo prevHash txs proof = do ouroborosPayload <- mkPayload encode cfg proof preHeader return $ SimpleBlock { simpleHeader = mkSimpleHeader preHeader ouroborosPayload @@ -368,6 +370,11 @@ 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 instance (SimpleBlockCrypto c, OuroborosTag p, Serialise (Payload p (SimplePreHeader p c))) => HasPreHeader (SimpleBlock p c) where @@ -375,6 +382,13 @@ instance (SimpleBlockCrypto c, OuroborosTag p, Serialise (Payload p (SimplePreHe blockPreHeader = headerPreHeader . simpleHeader +instance ( SimpleBlockCrypto c + , OuroborosTag p + , Serialise (Payload p (SimplePreHeader p c)) + ) + => HasPayload p (SimpleHeader p c) where + blockPayload _ = headerOuroboros + instance ( SimpleBlockCrypto c , OuroborosTag p , Serialise (Payload p (SimplePreHeader p c)) @@ -382,6 +396,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 +414,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,20 +448,30 @@ 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 + type GenTx (SimpleBlock p c) = 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 @@ -449,13 +488,18 @@ type AddrDist = Map Addr NodeId instance (BftCrypto c, SimpleBlockCrypto c') => ProtocolLedgerView (SimpleBlock (Bft c) c') where protocolLedgerView _ _ = () + anachronisticProtocolLedgerView _ _ _ = Just $ slotUnbounded () -- | 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 $ slotUnbounded pbftParams -- | Praos needs a ledger that can give it the "active stake distribution" -- @@ -469,20 +513,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 $ slotUnbounded $ 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 $ slotUnbounded () {------------------------------------------------------------------------------- Compute relative stake -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs index 0f83639b292..17f0b758cd3 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs @@ -20,26 +20,35 @@ class UpdateLedger b => ApplyTx b where -- also other kinds of things such as update proposals, delegations, etc. type 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 :: 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 :: LedgerConfig b + -> GenTx b + -> LedgerState b + -> LedgerState b -- | Mempool -- @@ -85,7 +94,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..9aa580467c1 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs @@ -28,10 +28,12 @@ module Ouroboros.Consensus.Node ( , Network.loggingChannel ) where +import Codec.CBOR.Encoding (Encoding) 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 +52,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 +64,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 +114,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 @@ -167,7 +173,8 @@ data NodeCallbacks m blk = NodeCallbacks { -- | Parameters required when initializing a node data NodeParams m up blk hdr = NodeParams { - tracer :: Tracer m String + encoder :: PreHeader blk -> Encoding + , tracer :: Tracer m String , threadRegistry :: ThreadRegistry m , maxClockSkew :: ClockSkew , cfg :: NodeConfig (BlockProtocol blk) @@ -187,16 +194,20 @@ nodeKernel , MonadTime m , MonadThrow (STM m) , ProtocolLedgerView blk + , LedgerConfigView blk , HasHeader hdr , HeaderHash hdr ~ HeaderHash blk + , SupportedBlock (BlockProtocol hdr) hdr + , SupportedPreHeader (BlockProtocol blk) (PreHeader hdr) , BlockProtocol hdr ~ BlockProtocol blk + , PreHeader blk ~ PreHeader hdr , Ord up , TraceConstraints up blk hdr , ApplyTx blk ) => 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 +225,7 @@ nodeKernel params@NodeParams { threadRegistry } = do return NodeKernel { getChainDB = chainDB , getMempool = mempool + , getNodeConfig = cfg , addUpstream = npAddUpstream (networkLayer st) , addDownstream = npAddDownstream (networkLayer st) } @@ -235,7 +247,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,7 +263,11 @@ initInternalState , HasHeader hdr , HeaderHash hdr ~ HeaderHash blk , ProtocolLedgerView blk + , LedgerConfigView blk + , SupportedBlock (BlockProtocol hdr) hdr + , SupportedPreHeader (BlockProtocol blk) (PreHeader hdr) , BlockProtocol hdr ~ BlockProtocol blk + , PreHeader blk ~ PreHeader hdr , Ord up , TraceConstraints up blk hdr , ApplyTx blk @@ -261,7 +277,7 @@ initInternalState initInternalState NodeParams {..} = do varCandidates <- atomically $ newTVar mempty varState <- atomically $ newTVar initState - mempool <- openMempool chainDB + mempool <- openMempool chainDB (ledgerConfigView cfg) fetchClientRegistry <- newFetchClientRegistry @@ -278,6 +294,7 @@ initInternalState NodeParams {..} = do nrChainSyncClient up = chainSyncClient (tracePrefix "CSClient" (Just up)) cfg + encoder btime maxClockSkew (ChainDB.getCurrentChain chainDB) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs index f69bd23207c..53f140c5d53 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs @@ -50,9 +50,13 @@ import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (HasHeader (..), SlotNo (..)) import Ouroboros.Network.Chain (Chain) +-- TODO Better place to put the Empty class? +import Ouroboros.Consensus.Crypto.DSIGN.Class (Empty) 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 @@ -136,10 +140,14 @@ class ( Show (ChainState p) -- | Blocks that the protocol can run on type family SupportedBlock p :: * -> Constraint + -- | Constraints on the preheader which can be incorporated into a payload. + type family SupportedPreHeader p :: * -> Constraint + type SupportedPreHeader p = Empty + -- | 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) + mkPayload :: (SupportedPreHeader p ph, HasNodeState p m, MonadRandom m) => (ph -> Encoding) -> NodeConfig p -> IsLeader p @@ -185,7 +193,9 @@ class ( Show (ChainState p) -> m (Maybe (IsLeader p)) -- | Apply a block - applyChainState :: SupportedBlock p b + -- + -- TODO this will only be used with headers + applyChainState :: (SupportedBlock p b, SupportedPreHeader p (PreHeader b), HasCallStack) => (PreHeader b -> Encoding) -- Serialiser for the preheader -> NodeConfig p -> LedgerView p -- /Updated/ ledger state @@ -196,6 +206,20 @@ 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 '2k' + -- slots. + -- + -- 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. + 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. diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs index 0eb67bb3f6c..c1cbf0d1da4 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs @@ -65,7 +65,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 @@ -106,16 +106,19 @@ instance BftCrypto c => OuroborosTag (Bft c) where applyChainState toEnc 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 + case verifySignedDSIGN + toEnc + (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 +133,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..78acb4b2817 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs @@ -43,6 +43,7 @@ instance (Typeable cfg, OuroborosTag p) => OuroborosTag (ExtNodeConfig cfg p) wh type ValidationErr (ExtNodeConfig cfg p) = ValidationErr p type IsLeader (ExtNodeConfig cfg p) = IsLeader p type SupportedBlock (ExtNodeConfig cfg p) = SupportedBlock p + type SupportedPreHeader (ExtNodeConfig cfg p) = SupportedPreHeader p -- -- Only type that changes is the node config @@ -64,6 +65,7 @@ instance (Typeable cfg, OuroborosTag p) => OuroborosTag (ExtNodeConfig cfg p) wh compareCandidates (EncNodeConfig cfg _) = compareCandidates cfg checkIsLeader (EncNodeConfig cfg _) = checkIsLeader cfg applyChainState toEnc (EncNodeConfig cfg _) = applyChainState toEnc 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..899a7fb7b8a 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs @@ -71,6 +71,7 @@ instance OuroborosTag p => OuroborosTag (WithLeaderSchedule p) where | otherwise -> Nothing 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..7382ae9dbd5 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs @@ -60,11 +60,13 @@ instance (Typeable p, Typeable s, ChainSelection p s) => OuroborosTag (ModChainS type LedgerView (ModChainSel p s) = LedgerView p type ValidationErr (ModChainSel p s) = ValidationErr p type SupportedBlock (ModChainSel p s) = SupportedBlock p + type SupportedPreHeader (ModChainSel p s) = SupportedPreHeader p mkPayload toEnc (McsNodeConfig cfg) proof ph = McsPayload <$> mkPayload toEnc cfg proof ph checkIsLeader (McsNodeConfig cfg) = checkIsLeader cfg applyChainState toEnc (McsNodeConfig cfg) = applyChainState toEnc 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..3c467cf1617 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -1,14 +1,19 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} module Ouroboros.Consensus.Protocol.PBFT ( PBft @@ -16,8 +21,8 @@ module Ouroboros.Consensus.Protocol.PBFT ( , PBftParams(..) -- * Classes , PBftCrypto(..) - , PBftStandardCrypto , PBftMockCrypto + , PBftCardanoCrypto -- * Type instances , NodeConfig(..) , Payload(..) @@ -27,48 +32,39 @@ 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.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 qualified Cardano.Chain.Genesis as CC.Genesis +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))) + -- TODO Use BiMap here + (Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)) + +deriving instance (Show (PBftVerKeyHash c)) => Show (PBftLedgerView c) {------------------------------------------------------------------------------- Protocol proper @@ -99,9 +95,16 @@ data PBftParams = PBftParams { -- | Signature threshold. This represents the proportion of blocks in a -- pbftSignatureWindow-sized window which may be signed by any single key. , pbftSignatureThreshold :: Double + + -- | Genesis config + -- + -- TODO: This doesn't really belong here; PBFT the consensus algorithm + -- does not require it. + , pbftGenesisConfig :: CC.Genesis.Config } -instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) 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 { pbftIssuer :: VerKeyDSIGN (PBftDSIGN c) @@ -117,8 +120,9 @@ instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) where , pbftVerKey :: VerKeyDSIGN (PBftDSIGN c) } - type ValidationErr (PBft c) = PBftValidationErr + type ValidationErr (PBft c) = PBftValidationErr c type SupportedBlock (PBft c) = HasPayload (PBft c) + type SupportedPreHeader (PBft c) = Signable (PBftDSIGN c) type NodeState (PBft c) = () -- | We require two things from the ledger state: @@ -133,10 +137,7 @@ 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 @@ -156,31 +157,45 @@ instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) where where PBftParams{..} = pbftParams - applyChainState toEnc cfg@PBftNodeConfig{..} (PBftLedgerView dms) b (signers, lastSlot) = do + applyChainState toEnc 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 + case verifySignedDSIGN + toEnc + (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.lookup (hashVerKey $ pbftIssuer payload) $ Bimap.twist 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 +218,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 -instance PBftCrypto PBftStandardCrypto where - type PBftDSIGN PBftStandardCrypto = Ed448DSIGN + hashVerKey :: VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c + +data PBftMockCrypto -instance PBftCrypto PBftMockCrypto where +instance (Signable MockDSIGN ~ Empty) => PBftCrypto PBftMockCrypto where type PBftDSIGN PBftMockCrypto = MockDSIGN + type PBftVerKeyHash PBftMockCrypto = VerKeyDSIGN MockDSIGN + + hashVerKey = id + +data PBftCardanoCrypto + +instance (Given ProtocolMagicId, Signable CardanoDSIGN ~ HasSignTag) => PBftCrypto PBftCardanoCrypto where + type PBftDSIGN PBftCardanoCrypto = CardanoDSIGN + type PBftVerKeyHash PBftCardanoCrypto = CC.Common.StakeholderId + + hashVerKey (VerKeyCardanoDSIGN pk)= CC.Common.mkStakeholderId pk diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs index e6cbf5c577d..a03fa1b3c81 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs @@ -93,7 +93,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 @@ -208,13 +208,18 @@ 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) + case verifySignedKES + (\(x,y) -> encodeListLen 2 <> toEnc 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 +253,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 = diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs index 67344c0a2b3..26309a43093 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs @@ -60,6 +60,7 @@ instance OuroborosTag p => OuroborosTag (TestProtocol p) where type ChainState (TestProtocol p) = ChainState p type ValidationErr (TestProtocol p) = ValidationErr p type SupportedBlock (TestProtocol p) = SupportedBlock p + type SupportedPreHeader (TestProtocol p) = SupportedPreHeader p mkPayload toEnc (TestNodeConfig cfg _) (proof, stake) ph = do standardPayload <- mkPayload toEnc cfg proof ph @@ -77,6 +78,7 @@ 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 + 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/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/Storage/ChainDB/Mock.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Mock.hs index bce2b182cf4..ab451d9e8c4 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Mock.hs @@ -31,6 +31,8 @@ openDB :: forall m blk hdr. , HasHeader hdr , HeaderHash blk ~ HeaderHash hdr , ProtocolLedgerView blk + , LedgerConfigView blk + , SupportedPreHeader (BlockProtocol blk) (PreHeader blk) ) => (PreHeader blk -> Encoding) -> NodeConfig (BlockProtocol blk) diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs index 22f2177dcf9..8ebf288ba32 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs @@ -117,7 +117,10 @@ empty initLedger = Model { , iterators = Map.empty } -addBlock :: forall blk. ProtocolLedgerView blk +addBlock :: forall blk. ( ProtocolLedgerView blk + , LedgerConfigView blk + , SupportedPreHeader (BlockProtocol blk) (PreHeader blk) + ) => (PreHeader blk -> Encoding) -> NodeConfig (BlockProtocol blk) -> blk -> Model blk -> Model blk @@ -140,7 +143,10 @@ addBlock toEnc cfg blk m = Model { (newChain, newLedger) = fromMaybe (currentChain m, currentLedger m) $ selectChain cfg (currentChain m) candidates -addBlocks :: forall blk. ProtocolLedgerView blk +addBlocks :: forall blk. ( ProtocolLedgerView blk + , LedgerConfigView blk + , SupportedPreHeader (BlockProtocol blk) (PreHeader blk) + ) => (PreHeader blk -> Encoding) -> NodeConfig (BlockProtocol blk) -> [blk] -> Model blk -> Model blk @@ -217,16 +223,26 @@ notGenesis p = GenesisHash -> error "Ouroboros.Storage.ChainDB.Model: notGenesis" BlockHash h -> h -validate :: ProtocolLedgerView blk +validate :: forall blk. + ( ProtocolLedgerView blk + , LedgerConfigView blk + , SupportedPreHeader (BlockProtocol blk) (PreHeader blk) + ) => (PreHeader blk -> Encoding) -> NodeConfig (BlockProtocol blk) -> ExtLedgerState blk -> Chain blk -> Maybe (Chain blk, ExtLedgerState blk) validate toEnc cfg initLedger chain = - either (const Nothing) (\ledger -> Just (chain, ledger)) + -- either (const Nothing) (\ledger -> Just (chain, ledger)) + fromEither . runExcept $ chainExtLedgerState toEnc 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..8d011bcf57f 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs @@ -101,12 +101,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 +146,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. @@ -228,7 +229,7 @@ runChainSync securityParam maxClockSkew (ClientUpdates clientUpdates) getLedgerState :: STM m (ExtLedgerState TestBlock) getLedgerState = snd <$> readTVar varClientState client = chainSyncClient - nullTracer (nodeCfg clientId) btime maxClockSkew + nullTracer (nodeCfg clientId) encode btime maxClockSkew getCurrentChain getLedgerState varCandidates serverId @@ -371,7 +372,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/General.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs index 347643480a8..ca2774f353d 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs @@ -16,6 +16,7 @@ module Test.Dynamic.General ( import Data.Map.Strict (Map) import Test.QuickCheck +import Codec.Serialise (Serialise) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork (MonadFork) import Control.Monad.Class.MonadSay @@ -29,14 +30,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 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 +prop_simple_protocol_convergence :: forall p c. + ( RunDemo p + , SimpleBlockCrypto c + , Block p ~ SimpleBlock p c + , SupportedBlock p (SimpleHeader p c) + , Serialise (Payload p (SimplePreHeader p c)) + ) => (CoreNodeId -> ProtocolInfo p) -> ( [NodeId] -> Map NodeId (Chain (Block p)) @@ -50,7 +59,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,7 +67,11 @@ test_simple_protocol_convergence :: forall m p. , MonadTime m , MonadTimer m , MonadThrow (STM m) - , DemoProtocolConstraints p + , RunDemo p + , Block p ~ SimpleBlock p c + , SimpleBlockCrypto c + , SupportedBlock p (SimpleHeader p c) + , Serialise (Payload p (SimplePreHeader p c)) ) => (CoreNodeId -> ProtocolInfo p) -> ( [NodeId] diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs index 67e48e35e4c..4a66920e52b 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs @@ -80,11 +80,12 @@ prop_simple_leader_schedule_convergence numSlots numCoreNodes params seed = numSlots seed where + nodeConfig = error "NodeConfig required in LeaderSchedule tests" isValid :: [NodeId] -> Map NodeId (Chain (Block DemoLeaderSchedule)) -> Property isValid nodeIds final = - counterexample (tracesToDot final) + counterexample (tracesToDot nodeConfig final) $ tabulate "shortestLength" [show (rangeK (praosSecurityParam params) (shortestLength final))] $ Map.keys final === nodeIds .&&. prop_all_common_prefix diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs index 3f34f1f3712..669df2e82f9 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs @@ -45,6 +45,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 import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.Random @@ -60,7 +61,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,9 +69,11 @@ broadcastNetwork :: forall m p blk hdr. , MonadTime m , MonadTimer m , MonadThrow (STM m) - , DemoProtocolConstraints p - , blk ~ Block p - , hdr ~ Header p + , RunDemo p + , SimpleBlockCrypto c + , Block p ~ SimpleBlock p c + , SupportedBlock p (SimpleHeader p c) + , Serialise (Payload p (SimplePreHeader p c)) ) => ThreadRegistry m -> BlockchainTime m @@ -78,7 +81,7 @@ broadcastNetwork :: forall m p blk hdr. -> (CoreNodeId -> ProtocolInfo p) -> ChaChaDRG -> NumSlots - -> m (Map NodeId (Chain blk)) + -> m (Map NodeId (Chain (SimpleBlock p c))) broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do -- all known addresses @@ -91,7 +94,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,7 +102,7 @@ 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) @@ -108,7 +111,7 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do -- We ignore the transactions from the mempool (which will be -- empty), and instead produce some random transactions txs <- genTxs addrs (getUtxo l) - forgeBlock pInfoConfig + demoForgeBlock pInfoConfig slot curNo prevHash @@ -122,6 +125,7 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do let nodeParams = NodeParams { tracer = nullTracer + , encoder = encode , threadRegistry = registry , maxClockSkew = ClockSkew 1 , cfg = pInfoConfig @@ -137,7 +141,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 +150,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 @@ -182,10 +186,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..f7c1e1fee70 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs @@ -56,20 +56,21 @@ 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 sigWin = fromIntegral $ nn * 10 sigThd = (1.0 / fromIntegral nn) + 0.1 - params = PBftParams sp (fromIntegral nn) sigWin sigThd + genesisConfig = error "Genesis config in PBFTParams is being accessed in Mock tests" + params = PBftParams sp (fromIntegral nn) sigWin sigThd genesisConfig isValid :: [NodeId] - -> Map NodeId (Chain (Block DemoPBFT)) + -> Map NodeId (Chain (Block DemoMockPBFT)) -> Property isValid nodeIds final = counterexample (show final) $ tabulate "shortestLength" [show (rangeK sp (shortestLength final))] $ Map.keys final === nodeIds .&&. allEqual (takeChainPrefix <$> Map.elems final) where - takeChainPrefix :: Chain (Block DemoPBFT) -> Chain (Block DemoPBFT) + takeChainPrefix :: Chain (Block DemoMockPBFT) -> Chain (Block DemoMockPBFT) 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..85e15df15e5 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs @@ -95,10 +95,15 @@ prop_simple_praos_convergence params numCoreNodes numSlots = -> Map NodeId (Chain (Block DemoPraos)) -> Property isValid nodeIds final = counterexample (show final) $ - let schedule = leaderScheduleFromTrace numSlots final + -- Oh dear, oh dear. This node config isn't used except in the RealPBFT + -- case, and it's not available here, so we leave it undefined. But this + -- isn't especially nice, since there's nothing stopping somebody changing + -- things later to use it. All of this only exists in test code, though. + let nc = error "Node config missing for Praos protocol" + schedule = leaderScheduleFromTrace nc numSlots final longest = longestCrowdedRun schedule crowded = crowdedRunLength longest - in counterexample (tracesToDot final) + in counterexample (tracesToDot nc final) $ counterexample (condense schedule) $ counterexample (show longest) $ label ("longest crowded run " <> show crowded) diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs index bf4765ed6b8..6401d585dfc 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -33,25 +34,26 @@ import Ouroboros.Network.Chain (Chain (..)) import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Consensus.BlockchainTime -import Ouroboros.Consensus.Demo (HasCreator (..)) +import Ouroboros.Consensus.Demo (HasCreator (..), Block) import Ouroboros.Consensus.Node +import Ouroboros.Consensus.Protocol.Abstract (NodeConfig) import Ouroboros.Consensus.Protocol.LeaderSchedule (LeaderSchedule (..)) import qualified Ouroboros.Consensus.Util.Chain as Chain import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () -allEqual :: forall b. (Condense b, Eq b, HasHeader b) => [Chain b] -> Property +allEqual :: forall b. (Condense (Block b), Eq (Block b), HasHeader (Block b)) => [Chain (Block b)] -> Property allEqual [] = property True allEqual [_] = property True allEqual (x : xs@(_:_)) = let c = foldl' Chain.commonPrefix x xs in foldl' (\prop d -> prop .&&. f c d) (property True) xs where - f :: Chain b -> Chain b -> Property + f :: Chain (Block b) -> Chain (Block b) -> Property f c d = counterexample (g c d) $ c == d - g :: Chain b -> Chain b -> String + g :: Chain (Block b) -> Chain (Block b) -> String g c d = case (Chain.lastSlot c, Chain.lastSlot d) of (Nothing, Nothing) -> error "impossible case" (Nothing, Just t) -> "empty intersection of non-empty chains (one reaches slot " @@ -74,7 +76,7 @@ allEqual (x : xs@(_:_)) = <> " /= " <> condense d -shortestLength :: Map NodeId (Chain b) -> Natural +shortestLength :: Map NodeId (Chain (Block b)) -> Natural shortestLength = fromIntegral . minimum . map Chain.length . Map.elems {------------------------------------------------------------------------------- @@ -84,8 +86,8 @@ shortestLength = fromIntegral . minimum . map Chain.length . Map.elems data BlockInfo b = BlockInfo { biSlot :: !SlotNo , biCreator :: !(Maybe CoreNodeId) - , biHash :: !(ChainHash b) - , biPrevious :: !(Maybe (ChainHash b)) + , biHash :: !(ChainHash (Block b)) + , biPrevious :: !(Maybe (ChainHash (Block b))) } genesisBlockInfo :: BlockInfo b @@ -96,10 +98,10 @@ genesisBlockInfo = BlockInfo , biPrevious = Nothing } -blockInfo :: (HasHeader b, HasCreator b) => b -> BlockInfo b -blockInfo b = BlockInfo +blockInfo :: (HasHeader (Block b), HasCreator b) => NodeConfig b -> Block 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 } @@ -134,25 +136,26 @@ data EdgeLabel = EdgeLabel instance Labellable EdgeLabel where toLabelValue = const $ StrLabel Text.empty -tracesToDot :: forall b. (HasHeader b, HasCreator b) - => Map NodeId (Chain b) +tracesToDot :: forall b. (HasHeader (Block b), HasCreator b) + => NodeConfig b + -> Map NodeId (Chain (Block b)) -> String -tracesToDot traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph +tracesToDot nc traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph where - chainBlockInfos :: Chain b -> Map (ChainHash b) (BlockInfo b) + chainBlockInfos :: Chain (Block b) -> Map (ChainHash (Block b)) (BlockInfo b) chainBlockInfos = 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 (ChainHash (Block b)) (BlockInfo b) blockInfos = Map.unions $ map chainBlockInfos $ Map.elems traces - lastHash :: Chain b -> ChainHash b + lastHash :: Chain (Block b) -> ChainHash (Block b) lastHash Genesis = GenesisHash lastHash (_ :> b) = BlockHash $ blockHash b - blockInfosAndBelievers :: Map (ChainHash b) (BlockInfo b, Set NodeId) + blockInfosAndBelievers :: Map (ChainHash (Block b)) (BlockInfo b, Set NodeId) blockInfosAndBelievers = Map.foldlWithKey f i traces where i = (\info -> (info, Set.empty)) <$> blockInfos @@ -162,7 +165,7 @@ tracesToDot traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph (lastHash chain) m - hashToId :: Map (ChainHash b) Node + hashToId :: Map (ChainHash (Block b)) Node hashToId = Map.fromList $ zip (Map.keys blockInfosAndBelievers) [0..] ns :: [LNode NodeLabel] @@ -187,18 +190,19 @@ tracesToDot traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph graph :: Gr NodeLabel EdgeLabel graph = mkGraph ns es -leaderScheduleFromTrace :: forall b. (HasCreator b, HasHeader b) - => NumSlots - -> Map NodeId (Chain b) +leaderScheduleFromTrace :: forall b. (HasCreator b, HasHeader (Block b)) + => NodeConfig b + -> NumSlots + -> Map NodeId (Chain (Block b)) -> LeaderSchedule -leaderScheduleFromTrace (NumSlots numSlots) = +leaderScheduleFromTrace nc (NumSlots numSlots) = LeaderSchedule . Map.foldl' (Chain.foldChain step) 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 :: Map SlotNo [CoreNodeId] -> Block b -> Map SlotNo [CoreNodeId] + step 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..6950b638ba8 100644 --- a/ouroboros-consensus/test-crypto/Test/Crypto/KES.hs +++ b/ouroboros-consensus/test-crypto/Test/Crypto/KES.hs @@ -81,7 +81,9 @@ 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 => proxy v @@ -91,8 +93,9 @@ 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 => proxy v @@ -104,7 +107,9 @@ 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 => proxy v @@ -117,7 +122,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 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..47e3e0ae3c8 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,7 @@ module Test.Ouroboros.Storage.ChainDB.Mock (tests) where -import Codec.Serialise (Serialise(encode)) +import Codec.Serialise (Serialise (encode)) import Control.Exception (Exception) import Control.Monad import Test.QuickCheck @@ -85,4 +85,4 @@ instance Exception InvalidUpdate -------------------------------------------------------------------------------} openDB :: forall s. SimM s (ChainDB (SimM s) TestBlock TestBlock) -openDB = Mock.openDB encode testConfig testInitExtLedger id +openDB = Mock.openDB encode 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..aeed51675d0 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,7 @@ module Test.Ouroboros.Storage.ChainDB.Model ( tests ) where -import Codec.Serialise (Serialise(encode)) +import Codec.Serialise (Serialise (encode)) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck @@ -30,26 +30,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 encode singleNodeTestConfig newBlock model) === Just newBlock where (newBlock:initBlocks) = permute p $ treeToBlocks bt - model = M.addBlocks encode testConfig initBlocks (M.empty testInitExtLedger) + model = M.addBlocks encode 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 encode 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 encode 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..ec3f69bf7b9 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 @@ -133,10 +133,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 +147,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 $ slotUnbounded () + +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 +173,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 +242,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 { From 102c7b3797d3d5ff0a8a8b802cc7b04614054d00 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 08:23:19 +0200 Subject: [PATCH 02/22] nix/regenerate.sh --- nix/.stack.nix/ouroboros-consensus.nix | 14 ++++++++++++++ 1 file changed, 14 insertions(+) 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) From 93218640ec938f7c757a510cfb39108e59374ac7 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 11:15:53 +0200 Subject: [PATCH 03/22] Address some issues in the ChainSyncClient --- .../Ouroboros/Consensus/ChainSyncClient.hs | 42 ++++++++++++------- 1 file changed, 28 insertions(+), 14 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs index d25913bd4f7..4291bf15d35 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs @@ -32,7 +32,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 (genesisPoint) +import Ouroboros.Network.Chain (genesisPoint, genesisSlotNo) import Ouroboros.Network.Protocol.ChainSync.Client import Ouroboros.Consensus.BlockchainTime @@ -101,7 +101,7 @@ instance ( Typeable hdr, StandardHash hdr data CandidateState hdr = CandidateState { candidateChain :: !(AnchoredFragment hdr) , candidateChainState :: !(ChainState (BlockProtocol hdr)) - -- ^ 'HeaderState' corresponding to the tip (most recent block) of the + -- ^ 'ChainState' corresponding to the tip (most recent block) of the -- 'candidateChain'. } @@ -150,7 +150,7 @@ chainSyncClient tracer cfg toEnc 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 'ChainState' corresponding to the head of the candidate -- chain. @@ -176,10 +176,9 @@ chainSyncClient tracer cfg toEnc btime (ClockSkew maxSkew) getCurrentChain -- this invariant cannot be maintained, the upstream node is on a fork that -- is too distant and we should disconnect. -- - -- 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? + -- 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. @@ -231,7 +230,8 @@ chainSyncClient tracer cfg toEnc btime (ClockSkew maxSkew) getCurrentChain ChainSyncClient . intersectUnchanged varCandidate } - -- One of the points we sent intersected our chain + -- 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) @@ -239,6 +239,21 @@ chainSyncClient tracer cfg toEnc btime (ClockSkew maxSkew) getCurrentChain CandidateState { candidateChain, candidateChainState } <- readTVar varCandidate -- Roll back the candidate to the @intersection@. + -- + -- 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) @@ -253,7 +268,7 @@ chainSyncClient tracer cfg toEnc btime (ClockSkew maxSkew) getCurrentChain -- hang on to the entire ledger state. This applies to everywhere we -- update the header state. writeTVar varCandidate CandidateState - { candidateChain = candidateChain' + { candidateChain = candidateChain' , candidateChainState = candidateChainState' } return $ requestNext varCandidate @@ -282,10 +297,9 @@ chainSyncClient tracer cfg toEnc 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 - - candidateChainState' <- case rewindChainState cfg curChainState (SlotNo 0) of + candidateChainState' <- case rewindChainState cfg curChainState genesisSlotNo of Nothing -> disconnect $ ForkTooDeep genesisPoint theirHead Just c -> pure c @@ -394,7 +408,7 @@ chainSyncClient tracer cfg toEnc btime (ClockSkew maxSkew) getCurrentChain Right candidateChainState' -> return candidateChainState' writeTVar varCandidate CandidateState - { candidateChain = candidateChain :> hdr + { candidateChain = candidateChain :> hdr , candidateChainState = candidateChainState' } return $ requestNext varCandidate @@ -427,7 +441,7 @@ chainSyncClient tracer cfg toEnc btime (ClockSkew maxSkew) getCurrentChain InvalidRollBack intersection theirHead writeTVar varCandidate CandidateState - { candidateChain = candidateChain' + { candidateChain = candidateChain' , candidateChainState = candidateChainState' } return $ requestNext varCandidate From fb1469a3786291e69fb9eeacc5a9efd1a2c6dbb8 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 12:22:56 +0200 Subject: [PATCH 04/22] Remove SupportedPreHeader This keeps the complication of Signable where it belongs (in PBFT). --- ouroboros-consensus/demo-playground/Run.hs | 5 +- .../Ouroboros/Consensus/ChainSyncClient.hs | 7 +-- .../src/Ouroboros/Consensus/Demo.hs | 7 --- .../Ouroboros/Consensus/Ledger/Abstract.hs | 34 +++++------ .../src/Ouroboros/Consensus/Ledger/Byron.hs | 57 +++++++------------ .../src/Ouroboros/Consensus/Ledger/Mock.hs | 20 ++++--- .../src/Ouroboros/Consensus/Node.hs | 9 +-- .../Ouroboros/Consensus/Protocol/Abstract.hs | 22 +++---- .../src/Ouroboros/Consensus/Protocol/BFT.hs | 10 ++-- .../Consensus/Protocol/ExtNodeConfig.hs | 7 +-- .../Consensus/Protocol/LeaderSchedule.hs | 4 +- .../Consensus/Protocol/ModChainSel.hs | 5 +- .../src/Ouroboros/Consensus/Protocol/PBFT.hs | 21 ++++--- .../src/Ouroboros/Consensus/Protocol/Praos.hs | 10 ++-- .../src/Ouroboros/Consensus/Protocol/Test.hs | 17 +++--- .../src/Ouroboros/Storage/ChainDB/Mock.hs | 9 +-- .../src/Ouroboros/Storage/ChainDB/Model.hs | 36 ++++-------- .../Test/Consensus/ChainSyncClient.hs | 7 +-- .../test-consensus/Test/Dynamic/Network.hs | 5 +- .../Test/Ouroboros/Storage/ChainDB/Mock.hs | 3 +- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 9 ++- .../test-util/Test/Util/TestBlock.hs | 1 + 22 files changed, 123 insertions(+), 182 deletions(-) diff --git a/ouroboros-consensus/demo-playground/Run.hs b/ouroboros-consensus/demo-playground/Run.hs index 73026d703a7..17d6dd19f20 100644 --- a/ouroboros-consensus/demo-playground/Run.hs +++ b/ouroboros-consensus/demo-playground/Run.hs @@ -107,14 +107,13 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do } chainDB :: ChainDB IO (Block p) (Header p) <- ChainDB.openDB - (demoEncodePreHeader pInfoConfig) pInfoConfig pInfoInitLedger + pInfoConfig pInfoInitLedger demoGetHeader btime <- realBlockchainTime registry slotDuration systemStart let tracer = contramap ((show myNodeId <> " | ") <>) stdoutTracer nodeParams = NodeParams - { encoder = demoEncodePreHeader pInfoConfig - , tracer = tracer + { tracer = tracer , threadRegistry = registry , maxClockSkew = ClockSkew 1 , cfg = pInfoConfig diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs index 4291bf15d35..f21c89050fd 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs @@ -16,7 +16,6 @@ module Ouroboros.Consensus.ChainSyncClient ( , CandidateState (..) ) where -import Codec.CBOR.Encoding (Encoding) import Control.Monad import Control.Monad.Except import Control.Tracer @@ -122,11 +121,9 @@ chainSyncClient , Condense hdr, Condense (ChainHash hdr) , BlockProtocol blk ~ BlockProtocol hdr , HeaderHash blk ~ HeaderHash hdr - , SupportedPreHeader (BlockProtocol hdr) (PreHeader hdr) ) => Tracer m String -> NodeConfig (BlockProtocol hdr) - -> (PreHeader hdr -> Encoding) -> BlockchainTime m -> ClockSkew -- ^ Maximum clock skew -> STM m (AnchoredFragment hdr) -- ^ Get the current chain @@ -135,7 +132,7 @@ chainSyncClient -- ^ The candidate chains, we need the whole map because we -- (de)register nodes (@up@). -> up -> Consensus ChainSyncClient hdr m -chainSyncClient tracer cfg toEnc btime (ClockSkew maxSkew) getCurrentChain +chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain getCurrentLedger varCandidates up = ChainSyncClient initialise where @@ -403,7 +400,7 @@ chainSyncClient tracer cfg toEnc btime (ClockSkew maxSkew) getCurrentChain -- Validate header CandidateState {..} <- readTVar varCandidate candidateChainState' <- - case runExcept $ applyChainState toEnc cfg ledgerView hdr candidateChainState of + case runExcept $ applyChainState cfg ledgerView hdr candidateChainState of Left vErr -> disconnect $ ChainError vErr Right candidateChainState' -> return candidateChainState' diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs index c66776e8343..5639903882b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs @@ -406,7 +406,6 @@ instance HasCreator DemoRealPBFT where type IsSimple p = ( Block p ~ SimpleBlock p SimpleBlockMockCrypto , Header p ~ SimpleHeader p SimpleBlockMockCrypto - , SupportedPreHeader p ~ Empty , Serialise.Serialise (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) ) @@ -423,7 +422,6 @@ class ( OuroborosTag p , HasHeader (Header p) , LedgerConfigView (Block p) , SupportedBlock (BlockProtocol (Header p)) (Header p) - , SupportedPreHeader p (PreHeader (Block p)) , PreHeader (Block p) ~ PreHeader (Header p) , Condense (Block p) , Condense [Block p] @@ -464,9 +462,6 @@ class ( OuroborosTag p demoEncodeHeaderHash :: NodeConfig p -> HeaderHash (Header p) -> Encoding default demoEncodeHeaderHash :: IsSimple p => NodeConfig p -> HeaderHash (Header p) -> Encoding - demoEncodePreHeader :: NodeConfig p -> PreHeader (Block p) -> Encoding - default demoEncodePreHeader :: IsSimple p => NodeConfig p -> PreHeader (Block p) -> Encoding - demoEncodeBlock :: NodeConfig p -> Block p -> Encoding default demoEncodeBlock :: IsSimple p => NodeConfig p -> Block p -> Encoding @@ -498,7 +493,6 @@ class ( OuroborosTag p demoGetHeader = Mock.simpleHeader demoEncodeHeader = const Serialise.encode demoEncodeHeaderHash = const Serialise.encode - demoEncodePreHeader = const Serialise.encode demoEncodeBlock = const Serialise.encode demoDecodeHeader = const Serialise.decode demoDecodeHeaderHash = const Serialise.decode @@ -532,7 +526,6 @@ instance ( Given Cardano.ProtocolMagicId demoGetHeader = byronHeader demoEncodeHeader = encodeByronDemoHeader demoEncodeHeaderHash = encodeByronDemoHeaderHash - demoEncodePreHeader = encodeByronDemoPreHeader demoEncodeBlock = encodeByronDemoBlock demoDecodeHeader = decodeByronDemoHeader demoDecodeHeaderHash = decodeByronDemoHeaderHash diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs index 54cf047dd16..c62316c7286 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs @@ -4,7 +4,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -188,26 +190,23 @@ 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 :: ( LedgerConfigView b +applyExtLedgerState :: forall b. + ( LedgerConfigView b , ProtocolLedgerView b - , SupportedPreHeader (BlockProtocol b) (PreHeader b) , HasCallStack ) - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig (BlockProtocol b) + => 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 $ applyLedgerHeader (ledgerConfigView cfg) b ledgerState ouroborosChainState' <- withExcept ExtValidationErrorOuroboros $ applyChainState - toEnc cfg (protocolLedgerView cfg ledgerState') b @@ -218,41 +217,34 @@ applyExtLedgerState toEnc cfg b ExtLedgerState{..} = do foldExtLedgerState :: ( LedgerConfigView b , ProtocolLedgerView b - , SupportedPreHeader (BlockProtocol b) (PreHeader b) , HasCallStack ) - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig (BlockProtocol b) + => 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 :: ( LedgerConfigView b , ProtocolLedgerView b - , SupportedPreHeader (BlockProtocol b) (PreHeader b) , HasCallStack ) - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig (BlockProtocol b) + => 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 :: ( LedgerConfigView b , ProtocolLedgerView b - , SupportedPreHeader (BlockProtocol b) (PreHeader b) ) - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig (BlockProtocol 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 index d3a115a6be1..e4997af6258 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -288,20 +288,24 @@ instance UpdateLedger (ByronBlock cfg) where 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 + blockPreHeader = unAnnotated . CC.Block.recoverSignedBytes given + . CC.Block.blockHeader . unByronBlock + encodePreHeader = const encodeByronDemoPreHeader -- 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 + blockPreHeader = unAnnotated . CC.Block.recoverSignedBytes given + . unByronHeader + encodePreHeader = const encodeByronDemoPreHeader -- 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 @@ -412,35 +416,6 @@ instance ( Given Crypto.ProtocolMagicId {------------------------------------------------------------------------------- Mempool integration - -class UpdateLedger b => ApplyTx b where - -- | Generalized transaction - -- - -- 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 :: * - - -- | Apply transaction we have not previously seen before - applyTx :: GenTx b - -> LedgerState b - -> Except (LedgerError 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 - -> LedgerState b - -> Except (LedgerError 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 -------------------------------------------------------------------------------} -- | Generalized transactions in Byron @@ -492,6 +467,9 @@ applyByronGenTx _reapply (ByronLedgerConfig cfg) = \genTx st@ByronLedgerState{.. Running Byron in the demo -------------------------------------------------------------------------------} +instance (Given CC.Block.HeaderHash, Given CC.Slot.EpochSlots) + => BlockSupportsPBft PBftCardanoCrypto (ByronHeader ByronDemoConfig) + -- Extended configuration we need for the demo data ByronDemoConfig = ByronDemoConfig { -- | Mapping from generic keys to core node IDs @@ -519,9 +497,13 @@ type ByronPayload = CC.Block.ToSign forgeByronDemoBlock - :: ( HasNodeState_ () m -- @()@ is the @NodeState@ of PBFT + :: 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 (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) -> SlotNo -- ^ Current slot @@ -531,7 +513,7 @@ forgeByronDemoBlock -> () -- ^ Leader proof (IsLeader) -> m (ByronBlock ByronDemoConfig) forgeByronDemoBlock cfg curSlot curNo prevHash txs () = do - ouroborosPayload <- mkPayload toCBOR cfg () preHeader + ouroborosPayload <- mkPayload (Proxy @(ByronBlock cfg)) cfg () preHeader -- traceM $ "Forge block: " ++ show (forgeBlock ouroborosPayload) return $ forgeBlock ouroborosPayload where @@ -776,9 +758,8 @@ encodeByronDemoHeaderHash :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBf -> HeaderHash (ByronHeader ByronDemoConfig) -> Encoding encodeByronDemoHeaderHash _cfg = toCBOR -encodeByronDemoPreHeader :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> PreHeader (ByronBlock ByronDemoConfig) -> Encoding -encodeByronDemoPreHeader _cfg = toCBOR +encodeByronDemoPreHeader :: PreHeader (ByronBlock ByronDemoConfig) -> Encoding +encodeByronDemoPreHeader = toCBOR decodeByronDemoHeader :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) -> Decoder s (ByronHeader ByronDemoConfig) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs index a8efb68775c..88297f28ff0 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs @@ -60,7 +60,6 @@ import GHC.Generics (Generic) import Ouroboros.Network.Block import Ouroboros.Network.Chain (Chain, toOldestFirst) -import Ouroboros.Consensus.Crypto.DSIGN.Class (Empty) import Ouroboros.Consensus.Crypto.Hash.Class import Ouroboros.Consensus.Crypto.Hash.MD5 (MD5) import Ouroboros.Consensus.Crypto.Hash.Short (ShortHash) @@ -322,8 +321,7 @@ forgeSimpleBlock :: forall m p c. , OuroborosTag p , SimpleBlockCrypto c , Serialise (Payload p (SimplePreHeader p c)) - -- TODO Decide whether we want to fix this constraint here. - , SupportedPreHeader p ~ Empty + , SupportedBlock p (SimpleBlock p c) ) => NodeConfig p -> SlotNo -- ^ Current slot @@ -333,7 +331,7 @@ forgeSimpleBlock :: forall m p c. -> IsLeader p -> m (SimpleBlock p c) forgeSimpleBlock cfg curSlot curNo prevHash txs proof = do - ouroborosPayload <- mkPayload encode cfg proof preHeader + ouroborosPayload <- mkPayload (Proxy @(SimpleBlock p c)) cfg proof preHeader return $ SimpleBlock { simpleHeader = mkSimpleHeader preHeader ouroborosPayload , simpleBody = body @@ -374,20 +372,22 @@ instance (SimpleBlockCrypto c, OuroborosTag p, Serialise (Payload p (SimplePreHe => HasPreHeader (SimpleHeader p c) where type PreHeader (SimpleHeader p c) = SimplePreHeader p c - blockPreHeader = headerPreHeader + 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 + blockPayload _ = headerOuroboros instance ( SimpleBlockCrypto c , OuroborosTag p @@ -490,6 +490,12 @@ instance (BftCrypto c, SimpleBlockCrypto c') protocolLedgerView _ _ = () anachronisticProtocolLedgerView _ _ _ = Just $ slotUnbounded () +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. diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs index 9aa580467c1..8435a8f9d9f 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs @@ -28,7 +28,6 @@ module Ouroboros.Consensus.Node ( , Network.loggingChannel ) where -import Codec.CBOR.Encoding (Encoding) import Codec.Serialise (Serialise) import Control.Monad (void) import Crypto.Random (ChaChaDRG) @@ -173,8 +172,7 @@ data NodeCallbacks m blk = NodeCallbacks { -- | Parameters required when initializing a node data NodeParams m up blk hdr = NodeParams { - encoder :: PreHeader blk -> Encoding - , tracer :: Tracer m String + tracer :: Tracer m String , threadRegistry :: ThreadRegistry m , maxClockSkew :: ClockSkew , cfg :: NodeConfig (BlockProtocol blk) @@ -198,9 +196,7 @@ nodeKernel , HasHeader hdr , HeaderHash hdr ~ HeaderHash blk , SupportedBlock (BlockProtocol hdr) hdr - , SupportedPreHeader (BlockProtocol blk) (PreHeader hdr) , BlockProtocol hdr ~ BlockProtocol blk - , PreHeader blk ~ PreHeader hdr , Ord up , TraceConstraints up blk hdr , ApplyTx blk @@ -265,9 +261,7 @@ initInternalState , ProtocolLedgerView blk , LedgerConfigView blk , SupportedBlock (BlockProtocol hdr) hdr - , SupportedPreHeader (BlockProtocol blk) (PreHeader hdr) , BlockProtocol hdr ~ BlockProtocol blk - , PreHeader blk ~ PreHeader hdr , Ord up , TraceConstraints up blk hdr , ApplyTx blk @@ -294,7 +288,6 @@ initInternalState NodeParams {..} = do nrChainSyncClient up = chainSyncClient (tracePrefix "CSClient" (Just up)) cfg - encoder btime maxClockSkew (ChainDB.getCurrentChain chainDB) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs index 53f140c5d53..4583a3ea345 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs @@ -50,8 +50,6 @@ import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (HasHeader (..), SlotNo (..)) import Ouroboros.Network.Chain (Chain) --- TODO Better place to put the Empty class? -import Ouroboros.Consensus.Crypto.DSIGN.Class (Empty) import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF import Ouroboros.Consensus.Util.Random @@ -140,19 +138,15 @@ class ( Show (ChainState p) -- | Blocks that the protocol can run on type family SupportedBlock p :: * -> Constraint - -- | Constraints on the preheader which can be incorporated into a payload. - type family SupportedPreHeader p :: * -> Constraint - type SupportedPreHeader p = Empty - -- | Construct the ouroboros-specific payload of a block -- -- Gets the proof that we are the leader and the preheader as arguments. - mkPayload :: (SupportedPreHeader p ph, 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? -- @@ -195,9 +189,8 @@ class ( Show (ChainState p) -- | Apply a block -- -- TODO this will only be used with headers - applyChainState :: (SupportedBlock p b, SupportedPreHeader p (PreHeader b), HasCallStack) - => (PreHeader b -> Encoding) -- Serialiser for the preheader - -> NodeConfig p + applyChainState :: (SupportedBlock p b, HasCallStack) + => NodeConfig p -> LedgerView p -- /Updated/ ledger state -> b -> ChainState p -- /Previous/ Ouroboros state @@ -235,7 +228,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 c1cbf0d1da4..c1ac2129113 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) @@ -89,8 +90,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,10 +105,11 @@ 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 + let proxy = Identity b case verifySignedDSIGN - toEnc + (encodePreHeader proxy) (bftVerKeys Map.! expectedLeader) (blockPreHeader b) (bftSignature (blockPayload cfg b)) of diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs index 78acb4b2817..bbf0aec0162 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs @@ -43,7 +43,6 @@ instance (Typeable cfg, OuroborosTag p) => OuroborosTag (ExtNodeConfig cfg p) wh type ValidationErr (ExtNodeConfig cfg p) = ValidationErr p type IsLeader (ExtNodeConfig cfg p) = IsLeader p type SupportedBlock (ExtNodeConfig cfg p) = SupportedBlock p - type SupportedPreHeader (ExtNodeConfig cfg p) = SupportedPreHeader p -- -- Only type that changes is the node config @@ -58,13 +57,13 @@ 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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs index 899a7fb7b8a..bb9f9263a52 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs @@ -70,8 +70,8 @@ instance OuroborosTag p => OuroborosTag (WithLeaderSchedule p) where | lsNodeConfigNodeId `elem` nids -> Just () | otherwise -> Nothing - applyChainState _ _ _ _ _ = return () - rewindChainState _ _ _ = Just () + 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 7382ae9dbd5..a9ac313732d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs @@ -60,12 +60,11 @@ instance (Typeable p, Typeable s, ChainSelection p s) => OuroborosTag (ModChainS type LedgerView (ModChainSel p s) = LedgerView p type ValidationErr (ModChainSel p s) = ValidationErr p type SupportedBlock (ModChainSel p s) = SupportedBlock p - type SupportedPreHeader (ModChainSel p s) = SupportedPreHeader 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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index 3c467cf1617..7e68be605da 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -23,6 +23,7 @@ module Ouroboros.Consensus.Protocol.PBFT ( , PBftCrypto(..) , PBftMockCrypto , PBftCardanoCrypto + , BlockSupportsPBft -- * Type instances , NodeConfig(..) , Payload(..) @@ -34,6 +35,7 @@ import qualified Codec.Serialise.Encoding as Enc import Control.Monad.Except 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 @@ -103,8 +105,11 @@ data PBftParams = PBftParams { , pbftGenesisConfig :: CC.Genesis.Config } -instance ( PBftCrypto c, Typeable c - ) => OuroborosTag (PBft c) where +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 { pbftIssuer :: VerKeyDSIGN (PBftDSIGN c) @@ -121,8 +126,7 @@ instance ( PBftCrypto c, Typeable c } type ValidationErr (PBft c) = PBftValidationErr c - type SupportedBlock (PBft c) = HasPayload (PBft c) - type SupportedPreHeader (PBft c) = Signable (PBftDSIGN c) + type SupportedBlock (PBft c) = BlockSupportsPBft c type NodeState (PBft c) = () -- | We require two things from the ledger state: @@ -141,8 +145,8 @@ instance ( PBftCrypto c, Typeable c 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 @@ -157,11 +161,12 @@ instance ( PBftCrypto c, Typeable c where PBftParams{..} = pbftParams - applyChainState toEnc cfg@PBftNodeConfig{..} lv@(PBftLedgerView dms) b chainState = 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. + let proxy = Identity b case verifySignedDSIGN - toEnc + (encodePreHeader proxy) (pbftIssuer payload) (blockPreHeader b) (pbftSignature payload) of diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs index a03fa1b3c81..2363c8457e3 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs @@ -31,6 +31,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 (..)) @@ -153,7 +154,7 @@ instance (Serialise (PraosExtraFields c), PraosCrypto c) => OuroborosTag (Praos type SupportedBlock (Praos c) = HasPayload (Praos 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 +162,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 +191,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,8 +209,9 @@ instance (Serialise (PraosExtraFields c), PraosCrypto c) => OuroborosTag (Praos Just vks -> return vks -- verify block signature + let proxy = Identity b case verifySignedKES - (\(x,y) -> encodeListLen 2 <> toEnc x <> encode y) + (\(x,y) -> encodeListLen 2 <> encodePreHeader proxy x <> encode y) vkKES (fromIntegral $ unSlotNo slot) (ph, praosExtraFields) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs index 26309a43093..14303864fae 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs @@ -56,14 +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 SupportedPreHeader (TestProtocol p) = SupportedPreHeader p - - mkPayload toEnc (TestNodeConfig cfg _) (proof, stake) ph = do - standardPayload <- mkPayload toEnc cfg proof ph + 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 proxy (TestNodeConfig cfg _) (proof, stake) ph = do + standardPayload <- mkPayload proxy cfg proof ph return TestPayload { testPayloadP = standardPayload , testPayloadStake = stake @@ -77,7 +76,7 @@ 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 diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Mock.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Mock.hs index ab451d9e8c4..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 (..), @@ -32,14 +31,12 @@ openDB :: forall m blk hdr. , HeaderHash blk ~ HeaderHash hdr , ProtocolLedgerView blk , LedgerConfigView blk - , SupportedPreHeader (BlockProtocol blk) (PreHeader 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 @@ -93,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 8ebf288ba32..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,14 +116,9 @@ empty initLedger = Model { , iterators = Map.empty } -addBlock :: forall blk. ( ProtocolLedgerView blk - , LedgerConfigView blk - , SupportedPreHeader (BlockProtocol blk) (PreHeader 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 @@ -136,21 +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 - , LedgerConfigView blk - , SupportedPreHeader (BlockProtocol blk) (PreHeader 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 @@ -226,23 +215,20 @@ notGenesis p = validate :: forall blk. ( ProtocolLedgerView blk , LedgerConfigView blk - , SupportedPreHeader (BlockProtocol blk) (PreHeader blk) ) - => (PreHeader blk -> Encoding) - -> NodeConfig (BlockProtocol 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) + fromEither (Right l) = Just (chain, l) chains :: forall blk. (HasHeader blk) => Map (HeaderHash blk) blk -> [Chain blk] diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs b/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs index 8d011bcf57f..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 @@ -229,7 +228,7 @@ runChainSync securityParam maxClockSkew (ClientUpdates clientUpdates) getLedgerState :: STM m (ExtLedgerState TestBlock) getLedgerState = snd <$> readTVar varClientState client = chainSyncClient - nullTracer (nodeCfg clientId) encode btime maxClockSkew + nullTracer (nodeCfg clientId) btime maxClockSkew getCurrentChain getLedgerState varCandidates serverId @@ -354,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" diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs index 669df2e82f9..1a19f2465b4 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs @@ -10,7 +10,7 @@ module Test.Dynamic.Network ( broadcastNetwork ) where -import Codec.Serialise (Serialise (encode)) +import Codec.Serialise (Serialise) import Control.Monad import Control.Tracer (nullTracer) import Crypto.Number.Generate (generateBetween) @@ -121,11 +121,10 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do , produceDRG = atomically $ simChaChaT varRNG id $ drgNew } - chainDB <- ChainDB.openDB encode pInfoConfig pInfoInitLedger simpleHeader + chainDB <- ChainDB.openDB pInfoConfig pInfoInitLedger simpleHeader let nodeParams = NodeParams { tracer = nullTracer - , encoder = encode , threadRegistry = registry , maxClockSkew = ClockSkew 1 , cfg = pInfoConfig 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 47e3e0ae3c8..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 singleNodeTestConfig 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 aeed51675d0..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,18 +29,18 @@ tests = testGroup "Model" [ prop_getBlock_addBlock :: BlockTree -> Permutation -> Property prop_getBlock_addBlock bt p = - M.getBlock (blockHash newBlock) (M.addBlock encode singleNodeTestConfig newBlock model) + M.getBlock (blockHash newBlock) (M.addBlock singleNodeTestConfig newBlock model) === Just newBlock where (newBlock:initBlocks) = permute p $ treeToBlocks bt - model = M.addBlocks encode singleNodeTestConfig 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 singleNodeTestConfig blocks (M.empty testInitExtLedger) + model = M.addBlocks singleNodeTestConfig blocks (M.empty testInitExtLedger) prop_alwaysPickPreferredChain :: BlockTree -> Permutation -> Property prop_alwaysPickPreferredChain bt p = @@ -51,5 +50,5 @@ prop_alwaysPickPreferredChain bt p = ] where blocks = permute p $ treeToBlocks bt - model = M.addBlocks encode singleNodeTestConfig 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/TestBlock.hs b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs index ec3f69bf7b9..5070018748c 100644 --- a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs @@ -111,6 +111,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 { From c4833e10ef70f82bfc2a23614a5c58f2081acb63 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 14:52:09 +0200 Subject: [PATCH 05/22] Define demo in terms of blocks, not protocol This is consistent with what we do elsewhere in the codebase, and cleans stuff up considerably. --- ouroboros-consensus/demo-playground/CLI.hs | 63 ++-- .../demo-playground/Mock/TxSubmission.hs | 8 +- ouroboros-consensus/demo-playground/Run.hs | 55 ++-- .../src/Ouroboros/Consensus/Demo.hs | 295 +++++++++--------- .../src/Ouroboros/Consensus/Ledger/Byron.hs | 30 +- .../src/Ouroboros/Consensus/Ledger/Mock.hs | 14 +- .../src/Ouroboros/Consensus/Mempool/API.hs | 2 +- .../test-consensus/Test/Dynamic/BFT.hs | 6 +- .../test-consensus/Test/Dynamic/General.hs | 20 +- .../Test/Dynamic/LeaderSchedule.hs | 3 +- .../test-consensus/Test/Dynamic/Network.hs | 27 +- .../test-consensus/Test/Dynamic/PBFT.hs | 6 +- .../test-consensus/Test/Dynamic/Praos.hs | 3 +- .../test-consensus/Test/Dynamic/Util.hs | 44 +-- 14 files changed, 306 insertions(+), 270 deletions(-) diff --git a/ouroboros-consensus/demo-playground/CLI.hs b/ouroboros-consensus/demo-playground/CLI.hs index a8956620184..064ad75711e 100644 --- a/ouroboros-consensus/demo-playground/CLI.hs +++ b/ouroboros-consensus/demo-playground/CLI.hs @@ -1,9 +1,14 @@ +{-# LANGUAGE GADTs #-} + module CLI ( - CLI(..) + -- * Untyped/typed protocol boundary + Protocol(..) + , SomeProtocol(..) + , fromProtocol + -- * CLI + , CLI(..) , TopologyInfo(..) , Command(..) - , Protocol(..) - , fromProtocol , parseCLI -- * Handy re-exports , execParser @@ -29,15 +34,9 @@ import Topology (TopologyInfo (..)) import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy -data CLI = CLI { - systemStart :: SystemStart - , slotDuration :: SlotLength - , command :: Command - } - -data Command = - SimpleNode TopologyInfo Protocol - | TxSubmitter TopologyInfo Mock.Tx +{------------------------------------------------------------------------------- + Untyped/typed protocol boundary +-------------------------------------------------------------------------------} data Protocol = BFT @@ -45,21 +44,49 @@ data Protocol = | MockPBFT | RealPBFT -fromProtocol :: Protocol -> IO (Some DemoProtocol) + +data SomeProtocol where + SomeProtocol :: RunDemo blk hdr => DemoProtocol blk hdr -> SomeProtocol + +fromProtocol :: Protocol -> IO SomeProtocol fromProtocol BFT = - return $ Some $ DemoBFT defaultSecurityParam + case runDemo p of + Dict -> return $ SomeProtocol p + where + p = DemoBFT defaultSecurityParam fromProtocol Praos = - return $ Some $ DemoPraos defaultDemoPraosParams + case runDemo p of + Dict -> return $ SomeProtocol p + where + p = DemoPraos defaultDemoPraosParams fromProtocol MockPBFT = - return $ Some $ DemoMockPBFT (defaultDemoPBftParams genesisConfig) + case runDemo p of + Dict -> return $ SomeProtocol p where + p = DemoMockPBFT (defaultDemoPBftParams genesisConfig) -- TODO: This is nasty genesisConfig = error "genesis config not needed when using mock ledger" -fromProtocol RealPBFT = do - return $ Some $ DemoRealPBFT (defaultDemoPBftParams genesisConfig) +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 + , command :: Command + } + +data Command = + SimpleNode TopologyInfo Protocol + | TxSubmitter TopologyInfo Mock.Tx + parseCLI :: Parser CLI parseCLI = CLI <$> parseSystemStart diff --git a/ouroboros-consensus/demo-playground/Mock/TxSubmission.hs b/ouroboros-consensus/demo-playground/Mock/TxSubmission.hs index aea2b3eb1c3..b7595cc86c9 100644 --- a/ouroboros-consensus/demo-playground/Mock/TxSubmission.hs +++ b/ouroboros-consensus/demo-playground/Mock/TxSubmission.hs @@ -99,9 +99,9 @@ submitTx n tx = do putStrLn $ "The Id for this transaction is: " <> condense (H.hash @ShortHash tx) -- | Auxiliary to 'spawnMempoolListener' -readIncomingTx :: RunDemo p +readIncomingTx :: RunDemo blk hdr => Tracer IO String - -> NodeKernel IO NodeId (Block p) (Header p) + -> NodeKernel IO NodeId blk hdr -> Decoder IO -> IO () readIncomingTx tracer kernel Decoder{..} = forever $ do @@ -112,10 +112,10 @@ readIncomingTx tracer kernel Decoder{..} = forever $ do " transaction: " <> show newTx -- | Listen for transactions coming a named pipe and add them to the mempool -spawnMempoolListener :: RunDemo p +spawnMempoolListener :: RunDemo blk hdr => Tracer IO String -> NodeId - -> NodeKernel IO NodeId (Block p) (Header p) + -> 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 17d6dd19f20..49e3bae19ec 100644 --- a/ouroboros-consensus/demo-playground/Run.hs +++ b/ouroboros-consensus/demo-playground/Run.hs @@ -33,7 +33,6 @@ import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.ChainSyncClient (ClockSkew (..)) import Ouroboros.Consensus.Demo import Ouroboros.Consensus.Node -import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.STM @@ -57,15 +56,14 @@ runNode cli@CLI{..} = do TxSubmitter topology tx -> handleTxSubmission topology tx SimpleNode topology protocol -> do - Some p <- fromProtocol protocol - case runDemo p of - Dict -> handleSimpleNode p cli topology + 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. RunDemo 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) <- @@ -85,14 +83,14 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do 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 - prevHash :: ChainHash (Header p) + prevHash :: ChainHash hdr prevHash = castHash (pointHash prevPoint) -- The transactions we get are consistent; the only reason not @@ -106,9 +104,10 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do proof } - chainDB :: ChainDB IO (Block p) (Header p) <- ChainDB.openDB - pInfoConfig pInfoInitLedger - demoGetHeader + chainDB :: ChainDB IO blk hdr <- ChainDB.openDB + pInfoConfig + pInfoInitLedger + demoGetHeader btime <- realBlockchainTime registry slotDuration systemStart let tracer = contramap ((show myNodeId <> " | ") <>) stdoutTracer @@ -144,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 @@ -160,8 +159,8 @@ 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' :: ProtocolInfo p - -> NodeKernel IO NodeId (Block p) (Header p) + addUpstream' :: ProtocolInfo blk + -> NodeKernel IO NodeId blk hdr -> NodeId -> IO () addUpstream' pInfo@ProtocolInfo{..} kernel producerNodeId = @@ -178,15 +177,15 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do } nodeCommsBF = NodeComms { ncCodec = codecBlockFetch - (demoEncodeBlock pInfoConfig) - (demoEncodeHeaderHash pInfoConfig) - (demoDecodeBlock pInfoConfig) - (demoDecodeHeaderHash pInfoConfig) + (demoEncodeBlock pInfoConfig) + demoEncodeHeaderHash + (demoDecodeBlock pInfoConfig) + demoDecodeHeaderHash , ncWithChan = NamedPipe.withPipeChannel "block-fetch" direction } - addDownstream' :: ProtocolInfo p - -> NodeKernel IO NodeId (Block p) (Header p) + addDownstream' :: ProtocolInfo blk + -> NodeKernel IO NodeId blk hdr -> NodeId -> IO () addDownstream' pInfo@ProtocolInfo{..} kernel consumerNodeId = @@ -203,17 +202,17 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do } nodeCommsBF = NodeComms { ncCodec = codecBlockFetch - (demoEncodeBlock pInfoConfig) - (demoEncodeHeaderHash pInfoConfig) - (demoDecodeBlock pInfoConfig) - (demoDecodeHeaderHash pInfoConfig) + (demoEncodeBlock pInfoConfig) + demoEncodeHeaderHash + (demoDecodeBlock pInfoConfig) + demoDecodeHeaderHash , ncWithChan = NamedPipe.withPipeChannel "block-fetch" direction } - encodePoint' :: ProtocolInfo p -> Point (Header p) -> Encoding + encodePoint' :: ProtocolInfo blk -> Point hdr -> Encoding encodePoint' ProtocolInfo{..} = - Block.encodePoint $ Block.encodeChainHash (demoEncodeHeaderHash pInfoConfig) + Block.encodePoint $ Block.encodeChainHash demoEncodeHeaderHash - decodePoint' :: forall s. ProtocolInfo p -> Decoder s (Point (Header p)) + decodePoint' :: forall s. ProtocolInfo blk -> Decoder s (Point hdr) decodePoint' ProtocolInfo{..} = - Block.decodePoint $ Block.decodeChainHash (demoDecodeHeaderHash pInfoConfig) + Block.decodePoint $ Block.decodeChainHash demoDecodeHeaderHash diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs index 5639903882b..191be50475e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs @@ -22,12 +22,13 @@ module Ouroboros.Consensus.Demo ( , DemoLeaderSchedule , DemoMockPBFT , DemoRealPBFT - , Block - , Header , NumCoreNodes(..) , ProtocolInfo(..) , protocolInfo , RunDemo(..) + , DemoBlock(..) + , DemoHeader(..) + , DemoHeaderHash(..) , runDemo -- * Support for runnig the demos , defaultSecurityParam @@ -39,6 +40,7 @@ module Ouroboros.Consensus.Demo ( 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 Crypto.Random (MonadRandom) @@ -61,7 +63,7 @@ import qualified Cardano.Crypto as Cardano import qualified Cardano.Crypto.Signing as Cardano.KeyGen import Ouroboros.Network.Block (BlockNo, ChainHash (..), HasHeader, - HeaderHash, SlotNo, StandardHash) + HeaderHash, SlotNo) import Ouroboros.Network.BlockFetch (SizeInBytes) import Ouroboros.Network.Chain (genesisPoint) @@ -99,47 +101,51 @@ type DemoMockPBFT = ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PB type DemoRealPBFT = ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto) -- | Consensus protocol to use -data DemoProtocol p where +data DemoProtocol blk hdr where -- | Run BFT against the mock ledger - DemoBFT :: SecurityParam -> DemoProtocol DemoBFT + DemoBFT + :: SecurityParam + -> DemoProtocol (SimpleBlock DemoBFT SimpleBlockMockCrypto) + (SimpleHeader DemoBFT SimpleBlockMockCrypto) -- | Run Praos against the mock ledger - DemoPraos :: PraosParams -> DemoProtocol DemoPraos + 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 DemoLeaderSchedule + DemoLeaderSchedule + :: LeaderSchedule + -> PraosParams + -> DemoProtocol (SimpleBlock DemoLeaderSchedule SimpleBlockMockCrypto) + (SimpleHeader DemoLeaderSchedule SimpleBlockMockCrypto) -- | Run PBFT against the mock ledger - DemoMockPBFT :: PBftParams -> DemoProtocol DemoMockPBFT + DemoMockPBFT + :: PBftParams + -> DemoProtocol (SimpleBlock DemoMockPBFT SimpleBlockMockCrypto) + (SimpleHeader DemoMockPBFT SimpleBlockMockCrypto) -- | Run PBFT against the real ledger - DemoRealPBFT :: PBftParams -> DemoProtocol DemoRealPBFT - -type family Block p = b | b -> p where - Block DemoRealPBFT = ByronBlock ByronDemoConfig - - -- Demos using mock ledger/block - Block p = SimpleBlock p SimpleBlockMockCrypto - -type family Header p :: * where - Header DemoRealPBFT = ByronHeader ByronDemoConfig - - -- Demos using mock ledger/block - Header p = SimpleHeader p SimpleBlockMockCrypto + DemoRealPBFT + :: PBftParams + -> DemoProtocol (ByronBlock ByronDemoConfig) + (ByronHeader ByronDemoConfig) -- | 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 } 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 { @@ -356,29 +362,29 @@ genesisStakeDist addrDist = Who created a block? -------------------------------------------------------------------------------} -class HasCreator p where - getCreator :: NodeConfig p -> Block p -> CoreNodeId +class HasCreator b where + getCreator :: NodeConfig (BlockProtocol b) -> b -> CoreNodeId -instance HasCreator DemoBFT where +instance HasCreator (SimpleBlock DemoBFT c) where getCreator _ = CoreNodeId . verKeyIdFromSigned . bftSignature . Mock.headerOuroboros . Mock.simpleHeader -instance HasCreator DemoPraos where +instance HasCreator (SimpleBlock DemoPraos c) where getCreator _ = praosCreator . praosExtraFields . encPayloadP . Mock.headerOuroboros . Mock.simpleHeader -instance HasCreator DemoLeaderSchedule where +instance HasCreator (SimpleBlock DemoLeaderSchedule c) where getCreator _ = getWLSPayload . Mock.headerOuroboros . Mock.simpleHeader -instance HasCreator DemoMockPBFT where +instance HasCreator (SimpleBlock DemoMockPBFT c) where getCreator _ = CoreNodeId . verKeyIdFromSigned . pbftSignature @@ -386,7 +392,7 @@ instance HasCreator DemoMockPBFT where . Mock.headerOuroboros . Mock.simpleHeader -instance HasCreator DemoRealPBFT where +instance HasCreator (ByronBlock ByronDemoConfig) where getCreator (EncNodeConfig _ ByronDemoConfig{..}) (ByronBlock b) = fromMaybe (error "getCreator: unknown key") $ Bimap.lookup key pbftCoreNodes where @@ -402,83 +408,29 @@ instance HasCreator DemoRealPBFT where Additional functions needed to run the demo -------------------------------------------------------------------------------} --- | The protocol @p@ uses simple (mock) blocks and headers -type IsSimple p = - ( Block p ~ SimpleBlock p SimpleBlockMockCrypto - , Header p ~ SimpleHeader p SimpleBlockMockCrypto - , Serialise.Serialise (Payload p (SimplePreHeader p SimpleBlockMockCrypto)) - ) - -class ( OuroborosTag p - , ProtocolLedgerView (Block p) - , HasCreator p - , Condense (Payload p (PreHeader (Block p))) - , Eq (Payload p (PreHeader (Block p))) - , Show (Payload p (PreHeader (Block p))) - , BlockProtocol (Block p) ~ p - , BlockProtocol (Header p) ~ p - , HeaderHash (Block p) ~ HeaderHash (Header p) - , StandardHash (Header p) - , HasHeader (Header p) - , LedgerConfigView (Block p) - , SupportedBlock (BlockProtocol (Header p)) (Header p) - , PreHeader (Block p) ~ PreHeader (Header p) - , Condense (Block p) - , Condense [Block p] - , Condense (Header p) - , Condense (ChainHash (Header p)) - , ApplyTx (Block p) - , Show (Block p) - , Show (Header p) - ) => RunDemo p where - - demoForgeBlock :: (HasNodeState p m, MonadRandom m) - => NodeConfig p - -> SlotNo -- ^ Current slot - -> BlockNo -- ^ Current block number - -> ChainHash (Header p) -- ^ Previous hash - -> [GenTx (Block p)] -- ^ Txs to add in the block - -> IsLeader p - -> m (Block p) - default demoForgeBlock :: IsSimple p - => (HasNodeState p m, MonadRandom m) - => NodeConfig p - -> SlotNo -- ^ Current slot - -> BlockNo -- ^ Current block number - -> ChainHash (Header p) -- ^ Previous hash - -> [GenTx (Block p)] -- ^ Txs to add in the block - -> IsLeader p - -> m (Block p) - - demoGetHeader :: Block p -> Header p - default demoGetHeader :: IsSimple p => Block p -> Header p - - -- We provide context for the encoders and decoders in case they need access - -- to stuff like "number of slots in an epoch" - - demoEncodeHeader :: NodeConfig p -> Header p -> Encoding - default demoEncodeHeader :: IsSimple p => NodeConfig p -> Header p -> Encoding - - demoEncodeHeaderHash :: NodeConfig p -> HeaderHash (Header p) -> Encoding - default demoEncodeHeaderHash :: IsSimple p => NodeConfig p -> HeaderHash (Header p) -> Encoding - - demoEncodeBlock :: NodeConfig p -> Block p -> Encoding - default demoEncodeBlock :: IsSimple p => NodeConfig p -> Block p -> Encoding - - demoDecodeHeader :: forall s. NodeConfig p -> Decoder s (Header p) - default demoDecodeHeader :: IsSimple p => forall s. NodeConfig p -> Decoder s (Header p) - - demoDecodeHeaderHash :: forall s. NodeConfig p -> Decoder s (HeaderHash (Header p)) - default demoDecodeHeaderHash :: IsSimple p => forall s. NodeConfig p -> Decoder s (HeaderHash (Header p)) - - demoDecodeBlock :: forall s. NodeConfig p -> Decoder s (Block p) - default demoDecodeBlock :: IsSimple p => forall s. NodeConfig p -> Decoder s (Block p) - - demoBlockFetchSize :: Header p -> SizeInBytes - default demoBlockFetchSize :: IsSimple p => Header p -> SizeInBytes - - demoBlockMatchesHeader :: Header p -> Block p -> Bool - default demoBlockMatchesHeader :: IsSimple p => Header p -> Block p -> Bool +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 -- @@ -486,22 +438,100 @@ class ( OuroborosTag p -- 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 p -> Mock.Tx -> GenTx (Block p) - default demoMockTx :: IsSimple p => NodeConfig p -> Mock.Tx -> GenTx (Block p) + 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 + +{------------------------------------------------------------------------------- + RunDemo instance for the mock ledger +-------------------------------------------------------------------------------} +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 - demoEncodeHeader = const Serialise.encode - demoEncodeHeaderHash = const Serialise.encode - demoEncodeBlock = const Serialise.encode - demoDecodeHeader = const Serialise.decode - demoDecodeHeaderHash = const Serialise.decode - demoDecodeBlock = const Serialise.decode - demoBlockFetchSize = Mock.headerBlockSize . Mock.headerPreHeader demoBlockMatchesHeader = Mock.blockMatchesHeader - demoMockTx = \_ -> id -runDemo :: DemoProtocol p -> Dict (RunDemo p) +{------------------------------------------------------------------------------- + RunDemo instance for PBFT with the real ledger +-------------------------------------------------------------------------------} + +instance DemoHeaderHash Cardano.Block.HeaderHash where + demoEncodeHeaderHash = encodeByronDemoHeaderHash + demoDecodeHeaderHash = decodeByronDemoHeaderHash + +instance ( Given Cardano.Block.HeaderHash + , Given Cardano.Slot.EpochSlots + ) => DemoHeader (ByronHeader ByronDemoConfig) where + demoEncodeHeader = encodeByronDemoHeader + demoDecodeHeader = decodeByronDemoHeader + demoBlockFetchSize = const 2000 -- TODO + +instance ( Given Cardano.Block.HeaderHash + , Given Cardano.ProtocolMagicId + , Given Cardano.Slot.EpochSlots + ) => DemoBlock (ByronBlock ByronDemoConfig) where + demoEncodeBlock = encodeByronDemoBlock + demoDecodeBlock = decodeByronDemoBlock + demoMockTx = elaborateByronTx + +instance ( Given Cardano.Block.HeaderHash + , Given Cardano.ProtocolMagicId + , Given Cardano.Slot.EpochSlots + ) => RunDemo (ByronBlock ByronDemoConfig) + (ByronHeader ByronDemoConfig) where + demoForgeBlock = forgeByronDemoBlock + demoGetHeader = byronHeader + demoBlockMatchesHeader = \_hdr _blk -> True -- TODO + +{------------------------------------------------------------------------------- + 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 @@ -510,26 +540,3 @@ runDemo DemoRealPBFT{} = give (Dummy.dummyEpochSlots) $ give (Cardano.Genesis.gdProtocolMagicId Dummy.dummyGenesisData) $ give (coerce @_ @Cardano.Block.HeaderHash Dummy.dummyGenesisHash) $ Dict - --- Protocols using SimpleBlock -instance RunDemo DemoBFT -instance RunDemo DemoPraos -instance RunDemo DemoLeaderSchedule -instance RunDemo DemoMockPBFT - -instance ( Given Cardano.ProtocolMagicId - , Given Cardano.Slot.EpochSlots - , Given Cardano.Block.HeaderHash - ) => RunDemo DemoRealPBFT where - - demoForgeBlock = forgeByronDemoBlock - demoGetHeader = byronHeader - demoEncodeHeader = encodeByronDemoHeader - demoEncodeHeaderHash = encodeByronDemoHeaderHash - demoEncodeBlock = encodeByronDemoBlock - demoDecodeHeader = decodeByronDemoHeader - demoDecodeHeaderHash = decodeByronDemoHeaderHash - demoDecodeBlock = decodeByronDemoBlock - demoBlockFetchSize = const 2000 -- TODO - demoBlockMatchesHeader _hdr _blk = True -- TODO - demoMockTx = elaborateByronTx diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs index e4997af6258..a5def09f51b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -418,14 +418,12 @@ instance ( Given Crypto.ProtocolMagicId Mempool integration -------------------------------------------------------------------------------} --- | Generalized transactions in Byron --- --- TODO: This is still missing the other cases (this shouldn't be a newtype) --- TODO: Should this use ATxAux instead? -newtype ByronGenTx = ByronTx { unByronTx :: CC.UTxO.ATxAux ByteString } - instance ApplyTx (ByronBlock cfg) where - type GenTx (ByronBlock cfg) = ByronGenTx + -- | Generalized transactions in Byron + -- + -- TODO: 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 @@ -441,14 +439,14 @@ instance ApplyTx (ByronBlock cfg) where applyByronGenTx :: Bool -- ^ Have we verified this transaction previously? -> LedgerConfig (ByronBlock cfg) - -> ByronGenTx + -> 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 :: ByronGenTx + 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] @@ -509,7 +507,7 @@ forgeByronDemoBlock -> SlotNo -- ^ Current slot -> BlockNo -- ^ Current block number -> ChainHash (ByronHeader cfg) -- ^ Previous hash - -> [ByronGenTx] -- ^ Txs to add in the block + -> [GenTx (ByronBlock cfg)] -- ^ Txs to add in the block -> () -- ^ Leader proof (IsLeader) -> m (ByronBlock ByronDemoConfig) forgeByronDemoBlock cfg curSlot curNo prevHash txs () = do @@ -615,7 +613,7 @@ forgeByronDemoBlock cfg curSlot curNo prevHash txs () = do -- -- This is adapted from 'Test.Cardano.Chain.Elaboration.UTxO.elaborateTxWits' elaborateByronTx :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> Mock.Tx -> ByronGenTx + -> Mock.Tx -> GenTx (ByronBlock cfg) elaborateByronTx cfg (Mock.Tx ins outs) = ByronTx $ CC.UTxO.ATxAux (annotate tx) (annotate witness) where @@ -754,9 +752,8 @@ encodeByronDemoBlock cfg = where epochSlots = pbftEpochSlots (encNodeConfigExt cfg) -encodeByronDemoHeaderHash :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> HeaderHash (ByronHeader ByronDemoConfig) -> Encoding -encodeByronDemoHeaderHash _cfg = toCBOR +encodeByronDemoHeaderHash :: HeaderHash (ByronHeader ByronDemoConfig) -> Encoding +encodeByronDemoHeaderHash = toCBOR encodeByronDemoPreHeader :: PreHeader (ByronBlock ByronDemoConfig) -> Encoding encodeByronDemoPreHeader = toCBOR @@ -787,9 +784,8 @@ decodeByronDemoBlock cfg = epochSlots = pbftEpochSlots (encNodeConfigExt cfg) -decodeByronDemoHeaderHash :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> Decoder s (HeaderHash (ByronHeader ByronDemoConfig)) -decodeByronDemoHeaderHash _cfg = fromCBOR +decodeByronDemoHeaderHash :: Decoder s (HeaderHash (ByronHeader ByronDemoConfig)) +decodeByronDemoHeaderHash = fromCBOR {------------------------------------------------------------------------------- This should be exported from -ledger diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs index 88297f28ff0..36db5f762e6 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs @@ -33,6 +33,8 @@ module Ouroboros.Consensus.Ledger.Mock ( , SimpleBody(..) , forgeSimpleBlock , blockMatchesHeader + -- * Mempool + , GenTx(..) -- * Updating the Ledger state , LedgerState(..) , AddrDist @@ -327,7 +329,7 @@ forgeSimpleBlock :: forall m p c. -> SlotNo -- ^ Current slot -> BlockNo -- ^ Current block number -> ChainHash (SimpleHeader p c) -- ^ Previous hash - -> [Tx] -- ^ Txs to add in the block + -> [GenTx (SimpleBlock p c)] -- ^ Txs to add in the block -> IsLeader p -> m (SimpleBlock p c) forgeSimpleBlock cfg curSlot curNo prevHash txs proof = do @@ -338,7 +340,7 @@ forgeSimpleBlock cfg curSlot curNo prevHash txs proof = do } 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 @@ -466,7 +468,7 @@ instance ( OuroborosTag p , SimpleBlockCrypto c , Serialise (Payload p (SimplePreHeader p c)) ) => ApplyTx (SimpleBlock p c) where - type GenTx (SimpleBlock p c) = Tx + newtype GenTx (SimpleBlock p c) = SimpleGenTx { simpleGenTx :: Tx } type ApplyTxErr (SimpleBlock p c) = LedgerError (SimpleBlock p c) applyTx = \_ -> updateSimpleLedgerState @@ -476,6 +478,12 @@ instance ( OuroborosTag p 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 -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs index 17f0b758cd3..11d42511522 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs @@ -18,7 +18,7 @@ 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 diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs index 51f7fd256a2..8e1c1d3e020 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,13 @@ prop_simple_bft_convergence k numCoreNodes = numCoreNodes where isValid :: [NodeId] - -> Map NodeId (Chain (Block DemoBFT)) + -> Map NodeId (Chain (SimpleBlock DemoBFT SimpleBlockMockCrypto)) -> Property isValid nodeIds final = counterexample (show final) $ tabulate "shortestLength" [show (rangeK k (shortestLength final))] $ Map.keys final === nodeIds .&&. allEqual (takeChainPrefix <$> Map.elems final) where - takeChainPrefix :: Chain (Block DemoBFT) -> Chain (Block DemoBFT) + 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 ca2774f353d..217408f68a5 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs @@ -16,7 +16,6 @@ module Test.Dynamic.General ( import Data.Map.Strict (Map) import Test.QuickCheck -import Codec.Serialise (Serialise) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork (MonadFork) import Control.Monad.Class.MonadSay @@ -32,7 +31,6 @@ 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.Orphans () import Ouroboros.Consensus.Util.Random import Ouroboros.Consensus.Util.ThreadRegistry @@ -40,15 +38,12 @@ import Ouroboros.Consensus.Util.ThreadRegistry import Test.Dynamic.Network prop_simple_protocol_convergence :: forall p c. - ( RunDemo p + ( RunDemo (SimpleBlock p c) (SimpleHeader p c) , SimpleBlockCrypto c - , Block p ~ SimpleBlock p c - , SupportedBlock p (SimpleHeader p c) - , Serialise (Payload p (SimplePreHeader p c)) ) - => (CoreNodeId -> ProtocolInfo p) + => (CoreNodeId -> ProtocolInfo (SimpleBlock p c)) -> ( [NodeId] - -> Map NodeId (Chain (Block p)) + -> Map NodeId (Chain (SimpleBlock p c)) -> Property) -> NumCoreNodes -> NumSlots @@ -67,15 +62,12 @@ test_simple_protocol_convergence :: forall m p c. , MonadTime m , MonadTimer m , MonadThrow (STM m) - , RunDemo p - , Block p ~ SimpleBlock p c + , RunDemo (SimpleBlock p c) (SimpleHeader p c) , SimpleBlockCrypto c - , SupportedBlock p (SimpleHeader p c) - , Serialise (Payload p (SimplePreHeader p c)) ) - => (CoreNodeId -> ProtocolInfo p) + => (CoreNodeId -> ProtocolInfo (SimpleBlock p c)) -> ( [NodeId] - -> Map NodeId (Chain (Block p)) + -> Map NodeId (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 4a66920e52b..c509745edef 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 @@ -82,7 +83,7 @@ prop_simple_leader_schedule_convergence numSlots numCoreNodes params seed = where nodeConfig = error "NodeConfig required in LeaderSchedule tests" isValid :: [NodeId] - -> Map NodeId (Chain (Block DemoLeaderSchedule)) + -> Map NodeId (Chain (SimpleBlock DemoLeaderSchedule SimpleBlockMockCrypto)) -> Property isValid nodeIds final = counterexample (tracesToDot nodeConfig final) diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs index 1a19f2465b4..c1cf5a23d93 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) 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,7 +43,6 @@ 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 import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.Random @@ -69,16 +66,13 @@ broadcastNetwork :: forall m p c. , MonadTime m , MonadTimer m , MonadThrow (STM m) - , RunDemo p + , RunDemo (SimpleBlock p c) (SimpleHeader p c) , SimpleBlockCrypto c - , Block p ~ SimpleBlock p c - , SupportedBlock p (SimpleHeader p c) - , Serialise (Payload p (SimplePreHeader p c)) ) => ThreadRegistry m -> BlockchainTime m -> NumCoreNodes - -> (CoreNodeId -> ProtocolInfo p) + -> (CoreNodeId -> ProtocolInfo (SimpleBlock p c)) -> ChaChaDRG -> NumSlots -> m (Map NodeId (Chain (SimpleBlock p c))) @@ -105,18 +99,21 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do 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) demoForgeBlock pInfoConfig - slot - curNo - prevHash - txs - proof + slot + curNo + prevHash + (map SimpleGenTx txs) + proof , produceDRG = atomically $ simChaChaT varRNG id $ drgNew } diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs index f7c1e1fee70..855c24b2f83 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 @@ -65,12 +66,13 @@ prop_simple_pbft_convergence sp numCoreNodes@(NumCoreNodes nn) = genesisConfig = error "Genesis config in PBFTParams is being accessed in Mock tests" params = PBftParams sp (fromIntegral nn) sigWin sigThd genesisConfig isValid :: [NodeId] - -> Map NodeId (Chain (Block DemoMockPBFT)) + -> Map NodeId (Chain (SimpleBlock DemoMockPBFT SimpleBlockMockCrypto)) -> Property isValid nodeIds final = counterexample (show final) $ tabulate "shortestLength" [show (rangeK sp (shortestLength final))] $ Map.keys final === nodeIds .&&. allEqual (takeChainPrefix <$> Map.elems final) where - takeChainPrefix :: Chain (Block DemoMockPBFT) -> Chain (Block DemoMockPBFT) + 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 85e15df15e5..99c8117a532 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,7 +93,7 @@ prop_simple_praos_convergence params numCoreNodes numSlots = PraosParams{..} = params isValid :: [NodeId] - -> Map NodeId (Chain (Block DemoPraos)) + -> Map NodeId (Chain (SimpleBlock DemoPraos SimpleBlockMockCrypto)) -> Property isValid nodeIds final = counterexample (show final) $ -- Oh dear, oh dear. This node config isn't used except in the RealPBFT diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs index 6401d585dfc..076d31ab105 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module Test.Dynamic.Util ( allEqual @@ -34,7 +35,8 @@ import Ouroboros.Network.Chain (Chain (..)) import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Consensus.BlockchainTime -import Ouroboros.Consensus.Demo (HasCreator (..), Block) +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 @@ -43,17 +45,17 @@ import qualified Ouroboros.Consensus.Util.Chain as Chain import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () -allEqual :: forall b. (Condense (Block b), Eq (Block b), HasHeader (Block b)) => [Chain (Block b)] -> Property +allEqual :: forall b. (Condense b, Eq b, HasHeader b) => [Chain b] -> Property allEqual [] = property True allEqual [_] = property True allEqual (x : xs@(_:_)) = let c = foldl' Chain.commonPrefix x xs in foldl' (\prop d -> prop .&&. f c d) (property True) xs where - f :: Chain (Block b) -> Chain (Block b) -> Property + f :: Chain b -> Chain b -> Property f c d = counterexample (g c d) $ c == d - g :: Chain (Block b) -> Chain (Block b) -> String + g :: Chain b -> Chain b -> String g c d = case (Chain.lastSlot c, Chain.lastSlot d) of (Nothing, Nothing) -> error "impossible case" (Nothing, Just t) -> "empty intersection of non-empty chains (one reaches slot " @@ -76,7 +78,7 @@ allEqual (x : xs@(_:_)) = <> " /= " <> condense d -shortestLength :: Map NodeId (Chain (Block b)) -> Natural +shortestLength :: Map NodeId (Chain b) -> Natural shortestLength = fromIntegral . minimum . map Chain.length . Map.elems {------------------------------------------------------------------------------- @@ -86,8 +88,8 @@ shortestLength = fromIntegral . minimum . map Chain.length . Map.elems data BlockInfo b = BlockInfo { biSlot :: !SlotNo , biCreator :: !(Maybe CoreNodeId) - , biHash :: !(ChainHash (Block b)) - , biPrevious :: !(Maybe (ChainHash (Block b))) + , biHash :: !(ChainHash b) + , biPrevious :: !(Maybe (ChainHash b)) } genesisBlockInfo :: BlockInfo b @@ -98,7 +100,9 @@ genesisBlockInfo = BlockInfo , biPrevious = Nothing } -blockInfo :: (HasHeader (Block b), HasCreator b) => NodeConfig b -> Block b -> BlockInfo b + +blockInfo :: (HasHeader b, HasCreator b) + => NodeConfig (BlockProtocol b) -> b -> BlockInfo b blockInfo nc b = BlockInfo { biSlot = blockSlot b , biCreator = Just $ getCreator nc b @@ -136,26 +140,26 @@ data EdgeLabel = EdgeLabel instance Labellable EdgeLabel where toLabelValue = const $ StrLabel Text.empty -tracesToDot :: forall b. (HasHeader (Block b), HasCreator b) - => NodeConfig b - -> Map NodeId (Chain (Block b)) +tracesToDot :: forall b. (HasHeader b, HasCreator b) + => NodeConfig (BlockProtocol b) + -> Map NodeId (Chain b) -> String tracesToDot nc traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph where - chainBlockInfos :: Chain (Block b) -> Map (ChainHash (Block b)) (BlockInfo b) + chainBlockInfos :: Chain b -> Map (ChainHash b) (BlockInfo b) chainBlockInfos = Chain.foldChain f (Map.singleton GenesisHash genesisBlockInfo) where f m b = let info = blockInfo nc b in Map.insert (biHash info) info m - blockInfos :: Map (ChainHash (Block b)) (BlockInfo b) + blockInfos :: Map (ChainHash b) (BlockInfo b) blockInfos = Map.unions $ map chainBlockInfos $ Map.elems traces - lastHash :: Chain (Block b) -> ChainHash (Block b) + lastHash :: Chain b -> ChainHash b lastHash Genesis = GenesisHash lastHash (_ :> b) = BlockHash $ blockHash b - blockInfosAndBelievers :: Map (ChainHash (Block b)) (BlockInfo b, Set NodeId) + blockInfosAndBelievers :: Map (ChainHash b) (BlockInfo b, Set NodeId) blockInfosAndBelievers = Map.foldlWithKey f i traces where i = (\info -> (info, Set.empty)) <$> blockInfos @@ -165,7 +169,7 @@ tracesToDot nc traces = Text.unpack $ printDotGraph $ graphToDot quickParams gra (lastHash chain) m - hashToId :: Map (ChainHash (Block b)) Node + hashToId :: Map (ChainHash b) Node hashToId = Map.fromList $ zip (Map.keys blockInfosAndBelievers) [0..] ns :: [LNode NodeLabel] @@ -190,10 +194,10 @@ tracesToDot nc traces = Text.unpack $ printDotGraph $ graphToDot quickParams gra graph :: Gr NodeLabel EdgeLabel graph = mkGraph ns es -leaderScheduleFromTrace :: forall b. (HasCreator b, HasHeader (Block b)) - => NodeConfig b +leaderScheduleFromTrace :: forall b. (HasCreator b, HasHeader b) + => NodeConfig (BlockProtocol b) -> NumSlots - -> Map NodeId (Chain (Block b)) + -> Map NodeId (Chain b) -> LeaderSchedule leaderScheduleFromTrace nc (NumSlots numSlots) = LeaderSchedule . Map.foldl' (Chain.foldChain step) initial @@ -201,7 +205,7 @@ leaderScheduleFromTrace nc (NumSlots numSlots) = initial :: Map SlotNo [CoreNodeId] initial = Map.fromList [(slot, []) | slot <- [1 .. fromIntegral numSlots]] - step :: Map SlotNo [CoreNodeId] -> Block b -> Map SlotNo [CoreNodeId] + step :: Map SlotNo [CoreNodeId] -> b -> Map SlotNo [CoreNodeId] step m b = Map.adjust (insert $ getCreator nc b) (blockSlot b) m insert :: CoreNodeId -> [CoreNodeId] -> [CoreNodeId] From 2af9213706ba79ab034e57e2fe500d6cb4faf6ee Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 14:14:15 +0200 Subject: [PATCH 06/22] Split off demo-specific Byron functionality Clean up these modules at the same time. --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../src/Ouroboros/Consensus/Demo.hs | 37 +- .../src/Ouroboros/Consensus/Ledger/Byron.hs | 915 ++++++------------ .../Ouroboros/Consensus/Ledger/Byron/Demo.hs | 401 ++++++++ 4 files changed, 737 insertions(+), 617 deletions(-) create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index bbe18d362ea..ffbf3f9eddb 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -50,6 +50,7 @@ library 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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs index 191be50475e..9f70026b14c 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs @@ -74,6 +74,7 @@ import Ouroboros.Consensus.Crypto.KES import Ouroboros.Consensus.Crypto.VRF import Ouroboros.Consensus.Ledger.Abstract 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 @@ -98,7 +99,7 @@ type DemoBFT = Bft BftMockCrypto type DemoPraos = ExtNodeConfig Mock.AddrDist (Praos PraosMockCrypto) type DemoLeaderSchedule = WithLeaderSchedule (Praos PraosMockCrypto) type DemoMockPBFT = ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PBftMockCrypto) -type DemoRealPBFT = ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto) +type DemoRealPBFT = ExtNodeConfig ByronDemo.Config (PBft PBftCardanoCrypto) -- | Consensus protocol to use data DemoProtocol blk hdr where @@ -130,8 +131,8 @@ data DemoProtocol blk hdr where -- | Run PBFT against the real ledger DemoRealPBFT :: PBftParams - -> DemoProtocol (ByronBlock ByronDemoConfig) - (ByronHeader ByronDemoConfig) + -> DemoProtocol (ByronBlock ByronDemo.Config) + (ByronHeader ByronDemo.Config) -- | Data required to run the specified protocol. data ProtocolInfo b = ProtocolInfo { @@ -262,7 +263,7 @@ protocolInfo (DemoRealPBFT params) , pbftSignKey = SignKeyCardanoDSIGN (snd (mkKey nid)) , pbftVerKey = VerKeyCardanoDSIGN (fst (mkKey nid)) } - , encNodeConfigExt = ByronDemoConfig { + , encNodeConfigExt = ByronDemo.Config { pbftCoreNodes = Bimap.fromList [ (fst (mkKey n), CoreNodeId n) | n <- [0 .. numCoreNodes] @@ -392,8 +393,8 @@ instance HasCreator (SimpleBlock DemoMockPBFT c) where . Mock.headerOuroboros . Mock.simpleHeader -instance HasCreator (ByronBlock ByronDemoConfig) where - getCreator (EncNodeConfig _ ByronDemoConfig{..}) (ByronBlock b) = +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 @@ -500,30 +501,30 @@ instance ( OuroborosTag p -------------------------------------------------------------------------------} instance DemoHeaderHash Cardano.Block.HeaderHash where - demoEncodeHeaderHash = encodeByronDemoHeaderHash - demoDecodeHeaderHash = decodeByronDemoHeaderHash + demoEncodeHeaderHash = ByronDemo.encodeHeaderHash + demoDecodeHeaderHash = ByronDemo.decodeHeaderHash instance ( Given Cardano.Block.HeaderHash , Given Cardano.Slot.EpochSlots - ) => DemoHeader (ByronHeader ByronDemoConfig) where - demoEncodeHeader = encodeByronDemoHeader - demoDecodeHeader = decodeByronDemoHeader + ) => DemoHeader (ByronHeader ByronDemo.Config) where + demoEncodeHeader = ByronDemo.encodeHeader + demoDecodeHeader = ByronDemo.decodeHeader demoBlockFetchSize = const 2000 -- TODO instance ( Given Cardano.Block.HeaderHash , Given Cardano.ProtocolMagicId , Given Cardano.Slot.EpochSlots - ) => DemoBlock (ByronBlock ByronDemoConfig) where - demoEncodeBlock = encodeByronDemoBlock - demoDecodeBlock = decodeByronDemoBlock - demoMockTx = elaborateByronTx + ) => 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 ByronDemoConfig) - (ByronHeader ByronDemoConfig) where - demoForgeBlock = forgeByronDemoBlock + ) => RunDemo (ByronBlock ByronDemo.Config) + (ByronHeader ByronDemo.Config) where + demoForgeBlock = ByronDemo.forgeBlock demoGetHeader = byronHeader demoBlockMatchesHeader = \_hdr _blk -> True -- TODO diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs index a5def09f51b..b28dc041700 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -1,77 +1,66 @@ -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_ghc -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wredundant-constraints #-} -module Ouroboros.Consensus.Ledger.Byron where +module Ouroboros.Consensus.Ledger.Byron + ( -- * Byron blocks and headers + ByronBlock (..) + , ByronHeader (..) + , byronHeader + -- * Mempool integration + , GenTx (..) + -- * Ledger + , LedgerState (..) + ) where -import Codec.CBOR.Decoding (Decoder) -import Codec.CBOR.Encoding (Encoding) -import qualified Codec.CBOR.Encoding as Encoding -import qualified Codec.CBOR.Read as CBOR -import qualified Codec.CBOR.Write as CBOR import Control.Monad.Except -import Crypto.Random (MonadRandom) -import Data.Bifunctor (bimap) -import Data.Bimap (Bimap) +import Data.Bifunctor (bimap, first) import qualified Data.Bimap as Bimap -import qualified Data.ByteString.Lazy as Lazy -import Data.Coerce +import Data.Coerce (coerce) import Data.FingerTree (Measured (..)) -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.Foldable (find, foldl') +import Data.Map (Map) import Data.Reflection (Given (..)) import qualified Data.Sequence as Seq -import qualified Data.Set as Set import qualified Data.Text as T import Data.Typeable -import qualified Data.Vector as V -import Data.Word +import Data.Word (Word16, Word8) import Formatting -import Cardano.Binary (Annotated (..), ByteSpan, fromCBOR, reAnnotate, - slice, toCBOR) +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 Delegation +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 Genesis +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.Update.Validation.Interface as CC.UPI import qualified Cardano.Chain.UTxO as CC.UTxO import qualified Cardano.Crypto as Crypto -import Cardano.Prelude (panic) 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 qualified Ouroboros.Consensus.Ledger.Mock as Mock import Ouroboros.Consensus.Mempool.API -import Ouroboros.Consensus.Node (CoreNodeId) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.ExtNodeConfig import Ouroboros.Consensus.Protocol.PBFT import Ouroboros.Consensus.Util.Condense -import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy + +{------------------------------------------------------------------------------- + Byron blocks and headers +-------------------------------------------------------------------------------} -- | Newtype wrapper to avoid orphan instances -- @@ -79,82 +68,27 @@ import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy -- 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 } +newtype ByronBlock cfg = ByronBlock + { unByronBlock :: CC.Block.ABlock ByteString + } deriving (Eq, Show) -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 - -newtype ByronHeader cfg = ByronHeader { unByronHeader :: CC.Block.AHeader ByteString } - deriving (Eq, Show) - -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 +newtype ByronHeader cfg = ByronHeader + { unByronHeader :: CC.Block.AHeader ByteString + } deriving (Eq, Show) -instance Condense (ChainHash (ByronHeader cfg)) where - condense GenesisHash = "genesis" - condense (BlockHash h) = show h byronHeader :: ByronBlock cfg -> ByronHeader cfg byronHeader (ByronBlock b) = ByronHeader (CC.Block.blockHeader b) -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 -convertSlot :: CC.Slot.FlatSlotId -> SlotNo -convertSlot = coerce - -convertFlatSlotId :: SlotNo -> CC.Slot.FlatSlotId -convertFlatSlotId = coerce +{------------------------------------------------------------------------------- + HasHeader instances +-------------------------------------------------------------------------------} -instance (Given CC.Block.HeaderHash, Typeable cfg) => HasHeader (ByronBlock cfg) where +instance (Given CC.Block.HeaderHash, Typeable cfg) + => HasHeader (ByronBlock cfg) where type HeaderHash (ByronBlock cfg) = CC.Block.HeaderHash blockHash = blockHash . byronHeader @@ -163,7 +97,8 @@ instance (Given CC.Block.HeaderHash, Typeable cfg) => HasHeader (ByronBlock cfg) blockNo = blockNo . byronHeader blockInvariant = const True -instance (Given CC.Block.HeaderHash, Typeable cfg) => HasHeader (ByronHeader cfg) where +instance (Given CC.Block.HeaderHash, Typeable cfg) + => HasHeader (ByronHeader cfg) where type HeaderHash (ByronHeader cfg) = CC.Block.HeaderHash -- Implementation of 'blockHash' derived from @@ -172,204 +107,231 @@ instance (Given CC.Block.HeaderHash, Typeable cfg) => HasHeader (ByronHeader cfg -- > blockHashAnnotated = hashDecoded . fmap wrapHeaderBytes . blockHeader -- -- I couldn't find a version for headers - blockHash = Crypto.hashDecoded . fmap CC.Block.wrapHeaderBytes . unByronHeader + blockHash = Crypto.hashDecoded + . fmap CC.Block.wrapHeaderBytes + . unByronHeader - -- We should distinguish the genesis hash - -- TODO: doing this correctly will require using the epoch boundary block + -- 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 + _ -> 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) -instance (Given Crypto.ProtocolMagicId, Typeable cfg) => LedgerConfigView (ByronBlock cfg) where - ledgerConfigView EncNodeConfig{..} = - ByronLedgerConfig $ pbftGenesisConfig (pbftParams encNodeConfigP) +{------------------------------------------------------------------------------- + Ledger +-------------------------------------------------------------------------------} + +instance (Given Crypto.ProtocolMagicId, Typeable cfg) + => LedgerConfigView (ByronBlock cfg) where + ledgerConfigView EncNodeConfig{..} = ByronLedgerConfig $ + pbftGenesisConfig (pbftParams encNodeConfigP) 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 + + newtype LedgerError (ByronBlock cfg) + = ByronLedgerError CC.Block.ChainValidationError deriving (Eq, Show) - newtype LedgerConfig (ByronBlock cfg) = ByronLedgerConfig Genesis.Config - applyLedgerBlock (ByronLedgerConfig cfg) (ByronBlock block) (ByronLedgerState state snapshots) - = mapExcept (bimap ByronLedgerError id) $ 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' = trimSnapshots $ - if (CC.Block.cvsDelegationState state' == CC.Block.cvsDelegationState state) - then snapshots - else - let startOfSnapshot = case snapshots of - _ Seq.:|> a -> sbUpper a - Seq.Empty -> SlotNo 0 - in snapshots Seq.|> slotBounded startOfSnapshot (convertSlot $ CC.Block.blockSlot block) state' - - pure $ ByronLedgerState state' snapshots' + 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.|> slotBounded 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.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 $ Genesis.configProtocolMagic cfg - , CC.Block.k = Genesis.configK cfg - , CC.Block.numGenKeys - , CC.Block.protocolParameters = CC.UPI.adoptedProtocolParameters . CC.Block.cvsUpdateState $ state - , CC.Block.currentEpoch = CC.Slot.slotNumberEpoch (Genesis.configEpochSlots cfg) (CC.Block.blockSlot block) + { 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) } - numGenKeys :: Word8 - numGenKeys = - case length (Genesis.unGenesisWStakeholders $ Genesis.configBootStakeholders cfg) of - n - | n > fromIntegral (maxBound :: Word8) -> panic - "updateBody: Too many genesis keys" - | otherwise -> fromIntegral n + + protocolParameters = CC.UPI.adoptedProtocolParameters . CC.Block.cvsUpdateState + $ state + fixPM (Crypto.AProtocolMagic a b) = Crypto.AProtocolMagic (reAnnotate a) b - trimSnapshots = Seq.dropWhileL (\ss -> sbUpper ss - < convertSlot (CC.Block.blockSlot block) - 2*(coerce $ Genesis.configK cfg)) - - 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) - pure $ state - { CC.Block.cvsLastSlot = CC.Block.blockSlot block - , CC.Block.cvsPreviousHash = Right $ CC.Block.blockHashAnnotated block - , CC.Block.cvsUpdateState = updateState - } + + 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 $ Genesis.configProtocolMagicId cfg - , CC.Block.k = Genesis.configK cfg - , CC.Block.numGenKeys - , CC.Block.delegationMap - , CC.Block.lastSlot = CC.Block.cvsLastSlot state + { 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 } - numGenKeys :: Word8 - numGenKeys = - case length (Genesis.unGenesisWStakeholders $ Genesis.configBootStakeholders cfg) of - n - | n > fromIntegral (maxBound :: Word8) -> panic - "updateBody: Too many genesis keys" - | otherwise -> fromIntegral n - - delegationMap = - V.Interface.delegationMap - $ CC.Block.cvsDelegationState 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 - } + 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 :: Map CC.Common.StakeholderId Word16 + genKeys = CC.Genesis.unGenesisWStakeholders + . CC.Genesis.configBootStakeholders + $ cfg {------------------------------------------------------------------------------- Support for PBFT consensus algorithm -------------------------------------------------------------------------------} -instance (Given CC.Block.HeaderHash, Given CC.Slot.EpochSlots, Typeable cfg) => BlockSupportsPBft PBftCardanoCrypto (ByronBlock cfg) +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 (ByronBlock cfg) = + ExtNodeConfig cfg (PBft PBftCardanoCrypto) -type instance BlockProtocol (ByronHeader 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 +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 encodeByronDemoPreHeader + 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 +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 encodeByronDemoPreHeader + 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 +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 + . 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 + . 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 +instance (Given CC.Slot.EpochSlots, Given CC.Block.HeaderHash, Typeable cfg) + => HasPayload (PBft PBftCardanoCrypto) (ByronBlock cfg) where blockPayload cfg = blockPayload cfg . byronHeader --- | Override the delegation map from the ledger view --- --- This is to work around a bug in cardano-ledger --- -reconstructDelegationMap :: Bimap CC.Common.StakeholderId CC.Common.StakeholderId -reconstructDelegationMap = - go $ Genesis.gdHeavyDelegation Dummy.dummyGenesisData - where - go :: Genesis.GenesisDelegation - -> Bimap CC.Common.StakeholderId CC.Common.StakeholderId - go = Bimap.fromList . map go' . Map.toList . Genesis.unGenesisDelegation - - go' :: (CC.Common.StakeholderId, Delegation.Certificate) - -> (CC.Common.StakeholderId, CC.Common.StakeholderId) - go' (from, to) = - if issuer /= from - then error "reconstructDelegationMap: unexpected issuer" - else (from, delegate) - where - issuer, delegate :: CC.Common.StakeholderId - issuer = CC.Common.mkStakeholderId $ Crypto.pskIssuerVK to - delegate = CC.Common.mkStakeholderId $ Crypto.pskDelegateVK to - instance ( Given Crypto.ProtocolMagicId , Given CC.Slot.EpochSlots , Given CC.Block.HeaderHash , Typeable cfg ) => ProtocolLedgerView (ByronBlock cfg) where - protocolLedgerView _ns (ByronLedgerState ls _) = PBftLedgerView - -- Delegation map - ( Delegation.unMap - . V.Interface.delegationMap - . CC.Block.cvsDelegationState - $ ls - ) + 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. + -- 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 @@ -377,40 +339,57 @@ instance ( Given Crypto.ProtocolMagicId 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 . Delegation.unMap - . V.Interface.delegationMap - . CC.Block.cvsDelegationState <$> sb + 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 -> - if slot >= lvLB && slot <= lvUB - then Just $ PBftLedgerView <$> - case Seq.takeWhileL (\sd -> convertSlot (V.Scheduling.sdSlot sd) <= slot) dsScheduled of - Seq.Empty -> -- No updates to apply. So the current ledger state is - -- valid from the end of the last snapshot to the first - -- scheduled update. - slotBounded lb ub dsNow - toApply@(_ Seq.:|> la) -> slotBounded lb (convertSlot . V.Scheduling.sdSlot $ la) - $ foldl (\acc x -> Bimap.insert (V.Scheduling.sdDelegator x) (V.Scheduling.sdDelegate x) acc) dsNow toApply - else 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 + 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 -> slotBounded lb ub dsNow + toApply@(_ Seq.:|> la) -> + slotBounded 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 = SlotNo $ if 2 * paramK > unSlotNo currentSlot then 0 else unSlotNo currentSlot - (2 * paramK) - dsNow = Delegation.unMap - . V.Interface.delegationMap - . CC.Block.cvsDelegationState - $ ls + 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 + . V.Interface.schedulingState + . CC.Block.cvsDelegationState + $ ls currentSlot = convertSlot $ CC.Block.cvsLastSlot ls containsSlot s sb = sbLower sb <= s && sbUpper sb >= s @@ -421,7 +400,8 @@ instance ( Given Crypto.ProtocolMagicId instance ApplyTx (ByronBlock cfg) where -- | Generalized transactions in Byron -- - -- TODO: This is still missing the other cases (this shouldn't be a newtype) + -- 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 @@ -429,13 +409,13 @@ instance ApplyTx (ByronBlock cfg) where applyTx = applyByronGenTx False reapplyTx = applyByronGenTx True - -- TODO: We need explicit support for this from the ledger + -- 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 $ "Ouroboros.Consensus.Ledger.Byron.reapplyTxSameState: unexpected error: " ++ show err - Right st' -> st' + 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) @@ -443,7 +423,7 @@ applyByronGenTx :: Bool -- ^ Have we verified this transaction previously? -> LedgerState (ByronBlock cfg) -> Except CC.UTxO.UTxOValidationError (LedgerState (ByronBlock cfg)) -applyByronGenTx _reapply (ByronLedgerConfig cfg) = \genTx st@ByronLedgerState{..} -> +applyByronGenTx _reapply (ByronLedgerConfig cfg) genTx st@ByronLedgerState{..} = (\x -> st { blsCurrent = x }) <$> go genTx blsCurrent where go :: GenTx (ByronBlock cfg) @@ -452,7 +432,7 @@ applyByronGenTx _reapply (ByronLedgerConfig cfg) = \genTx st@ByronLedgerState{.. go (ByronTx tx) cvs = wrapCVS <$> CC.UTxO.updateUTxO env utxo [tx] where wrapCVS newUTxO = cvs { CC.Block.cvsUtxo = newUTxO } - protocolMagic = fixPM $ Genesis.configProtocolMagic cfg + protocolMagic = fixPM $ CC.Genesis.configProtocolMagic cfg utxo = CC.Block.cvsUtxo cvs updateState = CC.Block.cvsUpdateState cvs env = CC.UTxO.Environment @@ -462,338 +442,75 @@ applyByronGenTx _reapply (ByronLedgerConfig cfg) = \genTx st@ByronLedgerState{.. fixPM (Crypto.AProtocolMagic a b) = Crypto.AProtocolMagic (reAnnotate a) b {------------------------------------------------------------------------------- - Running Byron in the demo --------------------------------------------------------------------------------} - -instance (Given CC.Block.HeaderHash, Given CC.Slot.EpochSlots) - => BlockSupportsPBft PBftCardanoCrypto (ByronHeader ByronDemoConfig) - --- Extended configuration we need for the demo -data ByronDemoConfig = ByronDemoConfig { - -- | 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 - - -- | TODO ok? - -- - -- We can use 'CC.Dummy.dummyGenesisHash' for this - , pbftGenesisHash :: Genesis.GenesisHash - , pbftGenesisDlg :: Genesis.GenesisDelegation - , pbftSecrets :: Genesis.GeneratedSecrets - } - -type ByronPayload = - Payload - (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - CC.Block.ToSign - -forgeByronDemoBlock - :: 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 (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> 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 ByronDemoConfig) -forgeByronDemoBlock cfg curSlot curNo prevHash txs () = do - ouroborosPayload <- mkPayload (Proxy @(ByronBlock cfg)) cfg () preHeader --- traceM $ "Forge block: " ++ show (forgeBlock ouroborosPayload) - return $ forgeBlock ouroborosPayload - where - ByronDemoConfig {..} = encNodeConfigExt cfg - - txPayload :: CC.UTxO.TxPayload - txPayload = CC.UTxO.mkTxPayload (map (fmap (const ()) . unByronTx) txs) - - body :: CC.Block.Body - body = CC.Block.ABody { - CC.Block.bodyTxPayload = txPayload - , CC.Block.bodySscPayload = CC.Ssc.SscPayload - , CC.Block.bodyDlgPayload = 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 - } - - forgeBlock :: ByronPayload -> ByronBlock ByronDemoConfig - forgeBlock 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 :: Delegation.Certificate - (headerGenesisKey, dlgCertificate) = case findDelegate of - Just x -> x - Nothing -> error "Issuer is not a valid genesis key delegate." - where - dlgMap = 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 (convertFlatSlotId 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' -elaborateByronTx :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> Mock.Tx -> GenTx (ByronBlock cfg) -elaborateByronTx 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 :: Int - mockOut = case lookup mockAddr (zip ["a", "b", "c", "d"] [0..]) of - Nothing -> error "elaborateByronTx: 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 - - -- TODO: Can we reuse these special "initial balance" addresses? Not sure - 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 (pbftParams (encNodeConfigP 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..] $ - 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 + Auxiliary -------------------------------------------------------------------------------} -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 - . toCBORBlockWithoutBoundary 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 +convertSlot :: CC.Slot.FlatSlotId -> SlotNo +convertSlot = coerce {------------------------------------------------------------------------------- - Serialisation + Condense instances -------------------------------------------------------------------------------} -encodeByronDemoHeader :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> ByronHeader ByronDemoConfig -> Encoding -encodeByronDemoHeader cfg = - CC.Block.toCBORHeader' epochSlots - . fmap (const ()) - . unByronHeader - where - epochSlots = pbftEpochSlots (encNodeConfigExt cfg) - -encodeByronDemoBlock :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> ByronBlock ByronDemoConfig -> Encoding -encodeByronDemoBlock cfg = - toCBORBlockWithoutBoundary epochSlots - . fmap (const ()) - . unByronBlock - where - epochSlots = pbftEpochSlots (encNodeConfigExt cfg) - -encodeByronDemoHeaderHash :: HeaderHash (ByronHeader ByronDemoConfig) -> Encoding -encodeByronDemoHeaderHash = toCBOR +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 -encodeByronDemoPreHeader :: PreHeader (ByronBlock ByronDemoConfig) -> Encoding -encodeByronDemoPreHeader = toCBOR +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 -decodeByronDemoHeader :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> Decoder s (ByronHeader ByronDemoConfig) -decodeByronDemoHeader cfg = - fmap (ByronHeader . annotate) $ - CC.Block.fromCBORAHeader epochSlots - where - -- TODO: 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 . fmap (const ()) - - epochSlots = pbftEpochSlots (encNodeConfigExt cfg) - -decodeByronDemoBlock :: NodeConfig (ExtNodeConfig ByronDemoConfig (PBft PBftCardanoCrypto)) - -> Decoder s (ByronBlock ByronDemoConfig) -decodeByronDemoBlock cfg = - fmap (ByronBlock . annotate) $ - CC.Block.fromCBORABlock epochSlots - where - -- TODO: 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 . fmap (const ()) + condenseKey :: Crypto.VerificationKey -> String + condenseKey = T.unpack . sformat build - epochSlots = pbftEpochSlots (encNodeConfigExt cfg) + condensedHash + = T.unpack + . sformat CC.Block.headerHashF + . Crypto.hashDecoded . fmap CC.Block.wrapHeaderBytes + . unByronHeader + $ hdr -decodeByronDemoHeaderHash :: Decoder s (HeaderHash (ByronHeader ByronDemoConfig)) -decodeByronDemoHeaderHash = fromCBOR + condensedPrevHash + = T.unpack + . sformat CC.Block.headerHashF + . CC.Block.headerPrevHash + . unByronHeader + $ hdr -{------------------------------------------------------------------------------- - This should be exported from -ledger --------------------------------------------------------------------------------} + condensedSlot + = T.unpack + . sformat build + . unAnnotated + . CC.Block.aHeaderSlot + . unByronHeader + $ hdr -toCBORBlockWithoutBoundary :: CC.Slot.EpochSlots -> CC.Block.Block -> Encoding -toCBORBlockWithoutBoundary epochSlots block - = Encoding.encodeListLen 3 - <> CC.Block.toCBORHeader' epochSlots (CC.Block.blockHeader block) - <> toCBOR (CC.Block.blockBody block) - <> (Encoding.encodeListLen 1 <> toCBOR (mempty :: Map Word8 Lazy.ByteString)) +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..5998e46d0f8 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs @@ -0,0 +1,401 @@ +{-# 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.Encoding as 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 Data.Word (Word8) + +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.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 + , pbftGenesisHash :: CC.Genesis.GenesisHash + , pbftGenesisDlg :: CC.Genesis.GenesisDelegation + , pbftSecrets :: CC.Genesis.GeneratedSecrets + } + +type ByronExtNodeConfig = ExtNodeConfig Config (PBft PBftCardanoCrypto) + +{------------------------------------------------------------------------------- + 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 (pbftParams (encNodeConfigP 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 + . toCBORBlockWithoutBoundary 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 = + toCBORBlockWithoutBoundary 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 + +{------------------------------------------------------------------------------- + This should be exported from cardano-ledger +-------------------------------------------------------------------------------} + +toCBORBlockWithoutBoundary :: CC.Slot.EpochSlots -> CC.Block.Block -> Encoding +toCBORBlockWithoutBoundary epochSlots block + = Encoding.encodeListLen 3 + <> CC.Block.toCBORHeader' epochSlots (CC.Block.blockHeader block) + <> toCBOR (CC.Block.blockBody block) + <> (Encoding.encodeListLen 1 <> toCBOR (mempty :: Map Word8 Lazy.ByteString)) From 72e48d6abcdeb98289cb544d12c3b1b8c3de96be Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 14:15:11 +0200 Subject: [PATCH 07/22] Add HasCallStack to reapplyTx(SameState) --- ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs index 11d42511522..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 @@ -35,7 +36,8 @@ class UpdateLedger b => ApplyTx b where -- 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 :: LedgerConfig b + reapplyTx :: HasCallStack + => LedgerConfig b -> GenTx b -> LedgerState b -> Except (ApplyTxErr b) (LedgerState b) @@ -45,7 +47,8 @@ class UpdateLedger b => ApplyTx b where -- In this case no error can occur. -- -- See also 'ldbConfReapply' for comments on implementing this function. - reapplyTxSameState :: LedgerConfig b + reapplyTxSameState :: HasCallStack + => LedgerConfig b -> GenTx b -> LedgerState b -> LedgerState b From fb1ef8c588d08679c8e53143a007b8dc44c3659d Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 14:32:49 +0200 Subject: [PATCH 08/22] Update the dependency on cardano-ledger Main reason: get rid of `toCBORBlockWithoutBoundary`. Deal with the renaming of `StakeholderId` to `KeyHash`. --- .stack-to-nix.cache | 7 +++++++ cabal.project | 14 ++++++------- nix/.stack.nix/cardano-crypto-test.nix | 4 ++-- nix/.stack.nix/cardano-crypto-wrapper.nix | 4 ++-- nix/.stack.nix/cardano-ledger-test.nix | 5 +++-- nix/.stack.nix/cardano-ledger.nix | 6 ++++-- nix/.stack.nix/cardano-shell.nix | 4 ++-- nix/.stack.nix/contra-tracer.nix | 4 ++-- nix/.stack.nix/iohk-monitoring.nix | 4 ++-- .../src/Ouroboros/Consensus/Ledger/Byron.hs | 10 ++++----- .../Ouroboros/Consensus/Ledger/Byron/Demo.hs | 21 ++++--------------- .../src/Ouroboros/Consensus/Protocol/PBFT.hs | 4 ++-- stack.yaml | 6 +++--- 13 files changed, 45 insertions(+), 48 deletions(-) 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/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs index b28dc041700..7d47917007b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -25,12 +25,12 @@ import qualified Data.Bimap as Bimap import Data.Coerce (coerce) import Data.FingerTree (Measured (..)) import Data.Foldable (find, foldl') -import Data.Map (Map) 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 (Word16, Word8) +import Data.Word (Word8) import Formatting import Cardano.Binary (Annotated (..), reAnnotate, toCBOR) @@ -256,9 +256,9 @@ numGenKeys cfg = case length genKeys of | otherwise -> fromIntegral n where - genKeys :: Map CC.Common.StakeholderId Word16 - genKeys = CC.Genesis.unGenesisWStakeholders - . CC.Genesis.configBootStakeholders + genKeys :: Set CC.Common.KeyHash + genKeys = CC.Genesis.unGenesisKeyHashes + . CC.Genesis.configGenesisKeyHashes $ cfg {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs index 5998e46d0f8..c2816786781 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs @@ -25,7 +25,6 @@ module Ouroboros.Consensus.Ledger.Byron.Demo import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding) -import qualified Codec.CBOR.Encoding as Encoding import qualified Codec.CBOR.Read as CBOR import qualified Codec.CBOR.Write as CBOR import Control.Monad (void) @@ -43,7 +42,6 @@ import Data.Reflection (Given (..)) import qualified Data.Set as Set import Data.Typeable import qualified Data.Vector as V -import Data.Word (Word8) import GHC.Stack (HasCallStack) @@ -311,7 +309,7 @@ annotateBlock :: CC.Slot.EpochSlots -> CC.Block.Block -> CC.Block.ABlock ByteStr annotateBlock epochSlots = (\bs -> splice bs (CBOR.deserialiseFromBytes (CC.Block.fromCBORABlock epochSlots) bs)) . CBOR.toLazyByteString - . toCBORBlockWithoutBoundary epochSlots + . CC.Block.toCBORBlock epochSlots where splice :: Lazy.ByteString -> Either err (Lazy.ByteString, CC.Block.ABlock ByteSpan) @@ -325,7 +323,7 @@ annotateHeader :: CC.Slot.EpochSlots -> CC.Block.Header -> CC.Block.AHeader Byte annotateHeader epochSlots = (\bs -> splice bs (CBOR.deserialiseFromBytes (CC.Block.fromCBORAHeader epochSlots) bs)) . CBOR.toLazyByteString - . CC.Block.toCBORHeader' epochSlots + . CC.Block.toCBORHeader epochSlots where splice :: Lazy.ByteString -> Either err (Lazy.ByteString, CC.Block.AHeader ByteSpan) @@ -342,7 +340,7 @@ annotateHeader epochSlots = encodeHeader :: NodeConfig ByronExtNodeConfig -> ByronHeader Config -> Encoding encodeHeader cfg = - CC.Block.toCBORHeader' epochSlots + CC.Block.toCBORHeader epochSlots . void . unByronHeader where @@ -351,7 +349,7 @@ encodeHeader cfg = encodeBlock :: NodeConfig ByronExtNodeConfig -> ByronBlock Config -> Encoding encodeBlock cfg = - toCBORBlockWithoutBoundary epochSlots + CC.Block.toCBORBlock epochSlots . void . unByronBlock where @@ -388,14 +386,3 @@ decodeBlock cfg = decodeHeaderHash :: Decoder s (HeaderHash (ByronHeader Config)) decodeHeaderHash = fromCBOR - -{------------------------------------------------------------------------------- - This should be exported from cardano-ledger --------------------------------------------------------------------------------} - -toCBORBlockWithoutBoundary :: CC.Slot.EpochSlots -> CC.Block.Block -> Encoding -toCBORBlockWithoutBoundary epochSlots block - = Encoding.encodeListLen 3 - <> CC.Block.toCBORHeader' epochSlots (CC.Block.blockHeader block) - <> toCBOR (CC.Block.blockBody block) - <> (Encoding.encodeListLen 1 <> toCBOR (mempty :: Map Word8 Lazy.ByteString)) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index 7e68be605da..296cab5636c 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -265,6 +265,6 @@ data PBftCardanoCrypto instance (Given ProtocolMagicId, Signable CardanoDSIGN ~ HasSignTag) => PBftCrypto PBftCardanoCrypto where type PBftDSIGN PBftCardanoCrypto = CardanoDSIGN - type PBftVerKeyHash PBftCardanoCrypto = CC.Common.StakeholderId + type PBftVerKeyHash PBftCardanoCrypto = CC.Common.KeyHash - hashVerKey (VerKeyCardanoDSIGN pk)= CC.Common.mkStakeholderId pk + hashVerKey (VerKeyCardanoDSIGN pk)= CC.Common.hashKey pk 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 From d23bcf7b2c4272a953c8ec342d61dde31098ba68 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 14:53:36 +0200 Subject: [PATCH 09/22] Remove unused pragmas from PBFT --- .../src/Ouroboros/Consensus/Protocol/PBFT.hs | 26 +++++++------------ 1 file changed, 10 insertions(+), 16 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index 296cab5636c..c6516d7e33f 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -1,19 +1,13 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE ViewPatterns #-} +{-# 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 From b6b0bbc148778d44b743ebdb2743f0288fb8d6be Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 15:30:31 +0200 Subject: [PATCH 10/22] Move mock protocol parameter stuff to Ledger.Demo --- .../src/Ouroboros/Consensus/Demo.hs | 55 ++++--------------- .../src/Ouroboros/Consensus/Ledger/Mock.hs | 41 +++++++++++++- 2 files changed, 50 insertions(+), 46 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs index 9f70026b14c..068478706e5 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs @@ -46,14 +46,12 @@ import Control.Monad.Except import Crypto.Random (MonadRandom) import qualified Data.Bimap as Bimap import Data.Coerce -import Data.Either (fromRight) 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 qualified Cardano.Chain.Block as Cardano.Block import qualified Cardano.Chain.Genesis as Cardano.Genesis @@ -65,7 +63,6 @@ import qualified Cardano.Crypto.Signing as Cardano.KeyGen import Ouroboros.Network.Block (BlockNo, ChainHash (..), HasHeader, HeaderHash, SlotNo) import Ouroboros.Network.BlockFetch (SizeInBytes) -import Ouroboros.Network.Chain (genesisPoint) import Ouroboros.Consensus.Crypto.DSIGN import Ouroboros.Consensus.Crypto.DSIGN.Mock (verKeyIdFromSigned) @@ -161,12 +158,12 @@ protocolInfo (DemoBFT securityParam) (NumCoreNodes numCoreNodes) (CoreNodeId nid | n <- [0 .. numCoreNodes - 1] ] } - , pInfoInitLedger = ExtLedgerState (genesisLedgerState addrDist) () + , pInfoInitLedger = ExtLedgerState (Mock.genesisLedgerState addrDist) () , pInfoInitState = () } where addrDist :: Mock.AddrDist - addrDist = mkAddrDist numCoreNodes + addrDist = Mock.mkAddrDist numCoreNodes protocolInfo (DemoPraos params) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = ProtocolInfo { pInfoConfig = EncNodeConfig { @@ -175,13 +172,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 ( @@ -192,7 +189,7 @@ protocolInfo (DemoPraos params) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = } where addrDist :: Mock.AddrDist - addrDist = mkAddrDist numCoreNodes + addrDist = Mock.mkAddrDist numCoreNodes verKeys :: IntMap (VerKeyKES MockKES, VerKeyVRF MockVRF) verKeys = IntMap.fromList [ (nd, (VerKeyMockKES nd, VerKeyMockVRF nd)) @@ -209,19 +206,19 @@ 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)) @@ -241,12 +238,12 @@ protocolInfo (DemoMockPBFT params) , encNodeConfigExt = PBftLedgerView (Bimap.fromList [(VerKeyMockDSIGN n, VerKeyMockDSIGN n) | n <- [0 .. numCoreNodes - 1]]) } - , pInfoInitLedger = ExtLedgerState (genesisLedgerState addrDist) Seq.empty + , pInfoInitLedger = ExtLedgerState (Mock.genesisLedgerState addrDist) Seq.empty , pInfoInitState = () } where addrDist :: Mock.AddrDist - addrDist = mkAddrDist numCoreNodes + addrDist = Mock.mkAddrDist numCoreNodes protocolInfo (DemoRealPBFT params) (NumCoreNodes numCoreNodes) @@ -327,38 +324,6 @@ enumCoreNodes (NumCoreNodes numNodes) = [ CoreNodeId n | n <- [0 .. numNodes - 1] ] -{------------------------------------------------------------------------------- - Parameters common to all protocols --------------------------------------------------------------------------------} - --- | Construct address to node ID mapping -mkAddrDist :: Int -- ^ Number of nodes - -> Mock.AddrDist -mkAddrDist numCoreNodes = - Map.fromList $ zip [[addr] | addr <- ['a'..]] - [CoreId n | n <- [0 .. numCoreNodes - 1]] - --- | Transaction giving initial stake to the nodes -genesisTx :: Mock.AddrDist -> Mock.Tx -genesisTx addrDist = Mock.Tx mempty [(addr, 1000) | addr <- Map.keys addrDist] - -genesisUtxo :: Mock.AddrDist -> Mock.Utxo -genesisUtxo addrDist = - fromRight (error "genesisLedger: invalid genesis tx") $ - runExcept (Mock.utxo (genesisTx addrDist)) - -genesisLedgerState :: Mock.AddrDist -> LedgerState (SimpleBlock p c) -genesisLedgerState addrDist = Mock.SimpleLedgerState { - slsUtxo = genesisUtxo addrDist - , slsConfirmed = Set.singleton (hash (genesisTx addrDist)) - , slsTip = genesisPoint - } - --- | Genesis stake distribution -genesisStakeDist :: Mock.AddrDist -> StakeDist -genesisStakeDist addrDist = - Mock.relativeStakes (Mock.totalStakes addrDist (genesisUtxo addrDist)) - {------------------------------------------------------------------------------- Who created a block? -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs index 36db5f762e6..bbdd4550473 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs @@ -40,6 +40,12 @@ module Ouroboros.Consensus.Ledger.Mock ( , AddrDist , relativeStakes , totalStakes + -- * Compute protocol parameters + , mkAddrDist + , genesisTx + , genesisUtxo + , genesisLedgerState + , genesisStakeDist ) where import Codec.CBOR.Decoding (decodeListLenOf) @@ -48,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) @@ -60,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) @@ -575,6 +582,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 -------------------------------------------------------------------------------} From d9865f76c847167a609ebe436134699930981d4e Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 15:43:31 +0200 Subject: [PATCH 11/22] Rename mkKey to lookupKey --- .../src/Ouroboros/Consensus/Demo.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs index 068478706e5..958ba0f39f9 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs @@ -257,12 +257,12 @@ protocolInfo (DemoRealPBFT params) , pbftSignatureWindow = 7 } , pbftNodeId = CoreId nid - , pbftSignKey = SignKeyCardanoDSIGN (snd (mkKey nid)) - , pbftVerKey = VerKeyCardanoDSIGN (fst (mkKey nid)) + , pbftSignKey = SignKeyCardanoDSIGN (snd (lookupKey nid)) + , pbftVerKey = VerKeyCardanoDSIGN (fst (lookupKey nid)) } , encNodeConfigExt = ByronDemo.Config { pbftCoreNodes = Bimap.fromList [ - (fst (mkKey n), CoreNodeId n) + (fst (lookupKey n), CoreNodeId n) | n <- [0 .. numCoreNodes] ] , pbftProtocolMagic = Cardano.Genesis.configProtocolMagic gc @@ -289,9 +289,12 @@ protocolInfo (DemoRealPBFT params) Right initState = runExcept $ Cardano.Block.initialChainValidationState (pbftGenesisConfig params) - mkKey :: Int -> (Cardano.VerificationKey, Cardano.SigningKey) - mkKey n = (\x -> (Cardano.KeyGen.toVerification x, x)) . (!! n) - . Cardano.Genesis.gsRichSecrets . fromJust $ Cardano.Genesis.configGeneratedSecrets 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 From 03a509898a8959650954d53167abd2f34a50771e Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 15:45:54 +0200 Subject: [PATCH 12/22] Cleanup usage of Empty In particular, thread it through for the KES stuff, even if we still require it to be empty in 'leaves'. --- .../Ouroboros/Consensus/Crypto/DSIGN/Class.hs | 5 +-- .../Ouroboros/Consensus/Crypto/KES/Class.hs | 16 +++++++--- .../Ouroboros/Consensus/Crypto/KES/Simple.hs | 14 ++++----- .../src/Ouroboros/Consensus/Ledger/Mock.hs | 6 ++++ .../src/Ouroboros/Consensus/Protocol/BFT.hs | 1 + .../src/Ouroboros/Consensus/Protocol/PBFT.hs | 10 +++--- .../src/Ouroboros/Consensus/Protocol/Praos.hs | 11 ++++++- .../src/Ouroboros/Consensus/Util.hs | 7 ++++- .../test-crypto/Test/Crypto/KES.hs | 31 +++++++++++++------ 9 files changed, 67 insertions(+), 34 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Class.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Class.hs index d368e200f3a..c5871e46559 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Class.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Class.hs @@ -10,7 +10,6 @@ module Ouroboros.Consensus.Crypto.DSIGN.Class ( DSIGNAlgorithm (..) , SignedDSIGN (..) - , Empty , signedDSIGN , verifySignedDSIGN , encodeSignedDSIGN @@ -24,11 +23,9 @@ import GHC.Exts (Constraint) import GHC.Generics (Generic) import GHC.Stack +import Ouroboros.Consensus.Util (Empty) import Ouroboros.Consensus.Util.Condense -class Empty a -instance Empty a - class ( Show (VerKeyDSIGN v) , Ord (VerKeyDSIGN v) , Show (SignKeyDSIGN v) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Class.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Class.hs index 0b24d16258c..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,14 @@ 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) + verifyKES :: Signable v a + => (a -> Encoding) -> VerKeyKES v -> Natural -> a -> SigKES v -> Either String () newtype SignedKES v a = SignedKES {getSig :: SigKES v} @@ -63,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 @@ -71,7 +77,7 @@ signedKES toEnc time a key = do Nothing -> Nothing Just (sig, key') -> Just (SignedKES sig, key') -verifySignedKES :: (KESAlgorithm v) +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/Simple.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Simple.hs index 37868a76d91..e87d4273781 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Simple.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/KES/Simple.hs @@ -12,9 +12,9 @@ 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 @@ -22,17 +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 - -- TODO We currently don't support other 'Signable' constraints for - -- KES. We could, but it's more stuff to do. So for the moment we fix - -- this here. - , Signable d ~ Empty - ) => KESAlgorithm (SimpleKES d) where +instance (DSIGNAlgorithm d) => KESAlgorithm (SimpleKES d) where newtype VerKeyKES (SimpleKES d) = VerKeySimpleKES (Vector (VerKeyDSIGN d)) deriving Generic @@ -44,6 +40,8 @@ instance ( DSIGNAlgorithm d newtype SigKES (SimpleKES d) = SigSimpleKES (SigDSIGN d) deriving Generic + type Signable (SimpleKES d) = DSIGN.Signable d + encodeVerKeyKES = encode encodeSignKeyKES = encode encodeSigKES = encode diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs index bbdd4550473..98f62d3b91a 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs @@ -522,6 +522,12 @@ instance (SimpleBlockCrypto c') anachronisticProtocolLedgerView (EncNodeConfig _ pbftParams) _ _ = Just $ slotUnbounded 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" -- -- TODO: Currently our mock ledger does not do this, and just assumes that all diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs index c1ac2129113..db7c746e9e4 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs @@ -38,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 {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index c6516d7e33f..ad729d5f428 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -249,16 +249,16 @@ class ( Typeable c data PBftMockCrypto -instance (Signable MockDSIGN ~ Empty) => PBftCrypto PBftMockCrypto where - type PBftDSIGN PBftMockCrypto = MockDSIGN +instance PBftCrypto PBftMockCrypto where + type PBftDSIGN PBftMockCrypto = MockDSIGN type PBftVerKeyHash PBftMockCrypto = VerKeyDSIGN MockDSIGN hashVerKey = id data PBftCardanoCrypto -instance (Given ProtocolMagicId, Signable CardanoDSIGN ~ HasSignTag) => PBftCrypto PBftCardanoCrypto where - type PBftDSIGN PBftCardanoCrypto = CardanoDSIGN +instance (Given ProtocolMagicId) => PBftCrypto PBftCardanoCrypto where + type PBftDSIGN PBftCardanoCrypto = CardanoDSIGN type PBftVerKeyHash PBftCardanoCrypto = CC.Common.KeyHash - hashVerKey (VerKeyCardanoDSIGN pk)= CC.Common.hashKey pk + 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 2363c8457e3..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(..) @@ -56,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 (..)) @@ -128,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 { @@ -151,7 +158,7 @@ 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 proxy PraosNodeConfig{..} PraosProof{..} preheader = do @@ -387,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/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/test-crypto/Test/Crypto/KES.hs b/ouroboros-consensus/test-crypto/Test/Crypto/KES.hs index 6950b638ba8..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 @@ -85,7 +94,7 @@ prop_KES_verify_pos _ d seed = | (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 @@ -97,7 +106,7 @@ prop_KES_verify_neg_key _ d seed = getDuration d > 0 ==> | (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 @@ -111,7 +120,7 @@ prop_KES_verify_neg_msg _ d a seed = | (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 @@ -141,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) = From 46f7a119c995779f7c89afc75e23529053f63792 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 16:09:23 +0200 Subject: [PATCH 13/22] Remove stray comment --- .../src/Ouroboros/Consensus/Protocol/PBFT.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index ad729d5f428..ba976eb1454 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -51,14 +51,10 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Test import Ouroboros.Consensus.Util.Condense -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. - -- TODO Use BiMap here - (Bimap (PBftVerKeyHash c) (PBftVerKeyHash 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) From 23cb8c7611539444ca923dd8a468b64c3981cc60 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 16:40:18 +0200 Subject: [PATCH 14/22] Remove GenesisConfig from PBFT --- ouroboros-consensus/demo-playground/CLI.hs | 6 ++---- .../src/Ouroboros/Consensus/Demo.hs | 17 ++++++++--------- .../src/Ouroboros/Consensus/Ledger/Byron.hs | 6 +----- .../Ouroboros/Consensus/Ledger/Byron/Demo.hs | 9 ++++++++- .../src/Ouroboros/Consensus/Protocol/PBFT.hs | 7 ------- .../test-consensus/Test/Dynamic/PBFT.hs | 3 +-- 6 files changed, 20 insertions(+), 28 deletions(-) diff --git a/ouroboros-consensus/demo-playground/CLI.hs b/ouroboros-consensus/demo-playground/CLI.hs index 064ad75711e..2501cfa0a0b 100644 --- a/ouroboros-consensus/demo-playground/CLI.hs +++ b/ouroboros-consensus/demo-playground/CLI.hs @@ -63,14 +63,12 @@ fromProtocol MockPBFT = case runDemo p of Dict -> return $ SomeProtocol p where - p = DemoMockPBFT (defaultDemoPBftParams genesisConfig) - -- TODO: This is nasty - genesisConfig = error "genesis config not needed when using mock ledger" + p = DemoMockPBFT defaultDemoPBftParams fromProtocol RealPBFT = case runDemo p of Dict -> return $ SomeProtocol p where - p = DemoRealPBFT (defaultDemoPBftParams genesisConfig) + p = DemoRealPBFT defaultDemoPBftParams genesisConfig genesisConfig = Dummy.dummyConfig {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs index 958ba0f39f9..b22aa2c32bf 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs @@ -128,6 +128,7 @@ data DemoProtocol blk hdr where -- | Run PBFT against the real ledger DemoRealPBFT :: PBftParams + -> Cardano.Genesis.Config -> DemoProtocol (ByronBlock ByronDemo.Config) (ByronHeader ByronDemo.Config) @@ -245,7 +246,7 @@ protocolInfo (DemoMockPBFT params) addrDist :: Mock.AddrDist addrDist = Mock.mkAddrDist numCoreNodes -protocolInfo (DemoRealPBFT params) +protocolInfo (DemoRealPBFT params gc) (NumCoreNodes numCoreNodes) (CoreNodeId nid) = ProtocolInfo { @@ -266,8 +267,9 @@ protocolInfo (DemoRealPBFT params) | n <- [0 .. numCoreNodes] ] , pbftProtocolMagic = Cardano.Genesis.configProtocolMagic gc - , pbftProtocolVersion = Cardano.Update.ProtocolVersion 3 1 4 - , pbftSoftwareVersion = Cardano.Update.SoftwareVersion (Cardano.Update.ApplicationName "harry the hamster") 1 + , 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 @@ -284,10 +286,8 @@ protocolInfo (DemoRealPBFT params) , pInfoInitState = () } where - gc = pbftGenesisConfig params initState :: Cardano.Block.ChainValidationState - Right initState = runExcept $ - Cardano.Block.initialChainValidationState (pbftGenesisConfig params) + Right initState = runExcept $ Cardano.Block.initialChainValidationState gc lookupKey :: Int -> (Cardano.VerificationKey, Cardano.SigningKey) lookupKey n = (\x -> (Cardano.KeyGen.toVerification x, x)) @@ -311,13 +311,12 @@ defaultDemoPraosParams = PraosParams { , praosLifetimeKES = 1000000 } -defaultDemoPBftParams :: Cardano.Genesis.Config -> PBftParams -defaultDemoPBftParams genesisConfig = PBftParams { +defaultDemoPBftParams :: PBftParams +defaultDemoPBftParams = PBftParams { pbftSecurityParam = defaultSecurityParam , pbftNumNodes = nn , pbftSignatureWindow = fromIntegral $ nn * 10 , pbftSignatureThreshold = (1.0 / fromIntegral nn) + 0.1 - , pbftGenesisConfig = genesisConfig } where nn = 3 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs index 7d47917007b..22da1cbf972 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.Ledger.Byron , GenTx (..) -- * Ledger , LedgerState (..) + , LedgerConfig (..) ) where import Control.Monad.Except @@ -146,11 +147,6 @@ instance StandardHash (ByronHeader cfg) Ledger -------------------------------------------------------------------------------} -instance (Given Crypto.ProtocolMagicId, Typeable cfg) - => LedgerConfigView (ByronBlock cfg) where - ledgerConfigView EncNodeConfig{..} = ByronLedgerConfig $ - pbftGenesisConfig (pbftParams encNodeConfigP) - instance UpdateLedger (ByronBlock cfg) where data LedgerState (ByronBlock cfg) = ByronLedgerState diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs index c2816786781..dfb55cbdecc 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Demo.hs @@ -61,6 +61,7 @@ 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) @@ -86,6 +87,7 @@ data Config = Config { , 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 @@ -93,6 +95,11 @@ data Config = Config { type ByronExtNodeConfig = ExtNodeConfig Config (PBft PBftCardanoCrypto) +instance (Given Crypto.ProtocolMagicId) + => LedgerConfigView (ByronBlock Config) where + ledgerConfigView EncNodeConfig{..} = ByronLedgerConfig $ + pbftGenesisConfig encNodeConfigExt + {------------------------------------------------------------------------------- Forging a new block -------------------------------------------------------------------------------} @@ -269,7 +276,7 @@ elaborateTx cfg (Mock.Tx ins outs) = . Map.toList . CC.UTxO.unUTxO . CC.UTxO.genesisUtxo - $ pbftGenesisConfig (pbftParams (encNodeConfigP cfg)) + $ pbftGenesisConfig (encNodeConfigExt cfg) where mkEntry :: CC.UTxO.TxIn -> CC.UTxO.TxOut diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index ba976eb1454..ed516c23490 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -38,7 +38,6 @@ import Data.Word (Word64) import GHC.Generics (Generic) import qualified Cardano.Chain.Common as CC.Common -import qualified Cardano.Chain.Genesis as CC.Genesis import Cardano.Crypto (ProtocolMagicId) import Ouroboros.Network.Block @@ -87,12 +86,6 @@ data PBftParams = PBftParams { -- | Signature threshold. This represents the proportion of blocks in a -- pbftSignatureWindow-sized window which may be signed by any single key. , pbftSignatureThreshold :: Double - - -- | Genesis config - -- - -- TODO: This doesn't really belong here; PBFT the consensus algorithm - -- does not require it. - , pbftGenesisConfig :: CC.Genesis.Config } class ( HasPayload (PBft c) b diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs index 855c24b2f83..f66deacb067 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs @@ -63,8 +63,7 @@ prop_simple_pbft_convergence sp numCoreNodes@(NumCoreNodes nn) = where sigWin = fromIntegral $ nn * 10 sigThd = (1.0 / fromIntegral nn) + 0.1 - genesisConfig = error "Genesis config in PBFTParams is being accessed in Mock tests" - params = PBftParams sp (fromIntegral nn) sigWin sigThd genesisConfig + params = PBftParams sp (fromIntegral nn) sigWin sigThd isValid :: [NodeId] -> Map NodeId (Chain (SimpleBlock DemoMockPBFT SimpleBlockMockCrypto)) -> Property From f0386d8cd5674a26b5f0a3d671fd20ff371222c3 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 16:48:38 +0200 Subject: [PATCH 15/22] Use proxy in HasSignTag --- .../src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs index 41cd942a189..5048b1a2dd6 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Crypto/DSIGN/Cardano.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -22,7 +23,8 @@ import Cardano.Crypto (ProtocolMagicId, ProxyVerificationKey, keyGen, signEncoded, toVerification, verifySignature) import Data.Coerce (coerce) import Data.Function (on) -import Data.Reflection (Given(..)) +import Data.Proxy (Proxy (..)) +import Data.Reflection (Given (..)) import GHC.Generics (Generic) import Ouroboros.Consensus.Crypto.DSIGN.Class @@ -30,7 +32,10 @@ import Ouroboros.Consensus.Util.Condense class HasSignTag a where - signTag :: a -> SignTag + signTag :: proxy a -> SignTag + +signTagFor :: forall a. HasSignTag a => a -> SignTag +signTagFor _ = signTag (Proxy @a) instance HasSignTag CC.UTxO.TxSigData where signTag = const SignTx @@ -70,10 +75,10 @@ instance Given ProtocolMagicId => DSIGNAlgorithm CardanoDSIGN where deriveVerKeyDSIGN (SignKeyCardanoDSIGN sk) = VerKeyCardanoDSIGN $ toVerification sk signDSIGN toEnc a (SignKeyCardanoDSIGN sk) = do - return $ SigCardanoDSIGN $ signEncoded given (signTag a) sk (toEnc a) + return $ SigCardanoDSIGN $ signEncoded given (signTagFor a) sk (toEnc a) verifyDSIGN toEnc (VerKeyCardanoDSIGN vk) a (SigCardanoDSIGN sig) = - if verifySignature toEnc given (signTag a) vk a $ coerce sig + if verifySignature toEnc given (signTagFor a) vk a $ coerce sig then Right () else Left "Verification failed" From c309f72ef19a8d7de886add12e5cdafe4e70ffe0 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 16:36:38 +0200 Subject: [PATCH 16/22] Clarify docstring of rewindChainState --- .../Ouroboros/Consensus/Protocol/Abstract.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs index 4583a3ea345..08dc4492c90 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs @@ -199,8 +199,8 @@ 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 '2k' - -- slots. + -- | 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. @@ -208,6 +208,19 @@ class ( Show (ChainState p) -- 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. From 1e2ce327448c6a6520de2a1fd7ef5bafda2c58e5 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 16:49:58 +0200 Subject: [PATCH 17/22] State an invariant of the candidate length in the ChainSyncClient --- .../src/Ouroboros/Consensus/ChainSyncClient.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs index f21c89050fd..6d3684039ba 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs @@ -434,6 +434,15 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain -- 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 From a96776616758713f0e2ba480a1927636420b50d6 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 16:52:29 +0200 Subject: [PATCH 18/22] Avoid use of twist --- ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index ed516c23490..298a168ebf8 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -163,7 +163,7 @@ instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) where unless (blockSlot b > lastSlot) $ throwError PBftInvalidSlot - case Bimap.lookup (hashVerKey $ pbftIssuer payload) $ Bimap.twist dms of + case Bimap.lookupR (hashVerKey $ pbftIssuer payload) dms of Nothing -> throwError $ PBftNotGenesisDelegate (hashVerKey $ pbftIssuer payload) lv Just gk -> do when (Seq.length signers >= winSize From 265143fc96bef6c7410e005abd36f3ddf2a73984 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 17:06:51 +0200 Subject: [PATCH 19/22] Move SlotBounded to separate module --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/ChainSyncClient.hs | 3 +- .../Ouroboros/Consensus/Ledger/Abstract.hs | 32 ++---------------- .../src/Ouroboros/Consensus/Ledger/Byron.hs | 9 ++--- .../src/Ouroboros/Consensus/Ledger/Mock.hs | 11 ++++--- .../Ouroboros/Consensus/Util/SlotBounded.hs | 33 +++++++++++++++++++ .../test-util/Test/Util/TestBlock.hs | 3 +- 7 files changed, 52 insertions(+), 40 deletions(-) create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Util/SlotBounded.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index ffbf3f9eddb..ef8ea8ab512 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -75,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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs index 6d3684039ba..53068a73e6e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs @@ -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 @@ -388,7 +389,7 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew) getCurrentChain -- TODO: Chain sync Client: Reuse anachronistic ledger view? #581 case anachronisticProtocolLedgerView cfg curLedger (pointSlot hdrPoint) of Nothing -> retry - Just view -> case atSlot (pointSlot hdrPoint) view of + Just view -> case view `SB.at` pointSlot hdrPoint of Nothing -> error "anachronisticProtocolLedgerView invariant violated" Just lv -> return lv diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs index c62316c7286..cc15f67486e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs @@ -13,12 +13,8 @@ -- | Interface to the ledger layer module Ouroboros.Consensus.Ledger.Abstract ( - SlotBounded(sbLower, sbUpper) - , slotUnbounded - , atSlot - , slotBounded -- * Interaction with the ledger layer - , UpdateLedger(..) + UpdateLedger(..) , BlockProtocol , ProtocolLedgerView(..) , LedgerConfigView(..) @@ -37,36 +33,14 @@ module Ouroboros.Consensus.Ledger.Abstract ( import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding) import Control.Monad.Except +import GHC.Stack import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util (repeatedlyM) +import Ouroboros.Consensus.Util.SlotBounded (SlotBounded) import Ouroboros.Network.Block (HasHeader (..), Point, SlotNo) import Ouroboros.Network.Chain (Chain, toOldestFirst) -import GHC.Stack - --- | 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. -slotBounded :: SlotNo -> SlotNo -> a -> SlotBounded a -slotBounded = SlotBounded - -slotUnbounded :: a -> SlotBounded a -slotUnbounded = SlotBounded minBound maxBound - -atSlot :: SlotNo -> SlotBounded a -> Maybe a -atSlot slot sb = - if (slot <= sbUpper sb && slot >= sbLower sb) - then Just $ sbContent sb - else Nothing - {------------------------------------------------------------------------------- Interaction with the ledger layer -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs index 22da1cbf972..f23da75456d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -57,7 +57,8 @@ 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 @@ -180,7 +181,7 @@ instance UpdateLedger (ByronBlock cfg) where CC.Block.cvsDelegationState state = snapshots | otherwise - = snapshots Seq.|> slotBounded startOfSnapshot slot state' + = snapshots Seq.|> SB.bounded startOfSnapshot slot state' where startOfSnapshot = case snapshots of _ Seq.:|> a -> sbUpper a @@ -351,9 +352,9 @@ instance ( Given Crypto.ProtocolMagicId -- 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 -> slotBounded lb ub dsNow + Seq.Empty -> SB.bounded lb ub dsNow toApply@(_ Seq.:|> la) -> - slotBounded lb (convertSlot . V.Scheduling.sdSlot $ la) $ + SB.bounded lb (convertSlot . V.Scheduling.sdSlot $ la) $ foldl' (\acc x -> Bimap.insert (V.Scheduling.sdDelegator x) (V.Scheduling.sdDelegate x) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs index 98f62d3b91a..223f076fdda 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs @@ -85,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] @@ -503,7 +503,7 @@ type AddrDist = Map Addr NodeId instance (BftCrypto c, SimpleBlockCrypto c') => ProtocolLedgerView (SimpleBlock (Bft c) c') where protocolLedgerView _ _ = () - anachronisticProtocolLedgerView _ _ _ = Just $ slotUnbounded () + anachronisticProtocolLedgerView _ _ _ = Just $ SB.unbounded () instance (SimpleBlockCrypto c') => BlockSupportsPBft PBftMockCrypto (SimpleBlock (ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PBftMockCrypto)) c') @@ -520,7 +520,7 @@ instance (SimpleBlockCrypto c') -- This instance is correct, because the delegation map doesn't change in the -- node configuration. anachronisticProtocolLedgerView (EncNodeConfig _ pbftParams) _ _ - = Just $ slotUnbounded pbftParams + = Just $ SB.unbounded pbftParams instance (PraosCrypto c, SimpleBlockCrypto c') => (BlockSupportsPraos c (SimpleBlock (ExtNodeConfig AddrDist (Praos c)) c')) @@ -542,7 +542,7 @@ instance ( PraosCrypto c, SimpleBlockCrypto c') equalStakeDistr addrDist anachronisticProtocolLedgerView (EncNodeConfig _ addrDist) _ _ = - Just $ slotUnbounded $ equalStakeDistr addrDist + Just $ SB.unbounded $ equalStakeDistr addrDist nodeStake :: NodeId -> Maybe (Int, Rational) nodeStake (RelayId _) = Nothing @@ -556,7 +556,8 @@ equalStakeDistr = IntMap.fromList instance (PraosCrypto c, SimpleBlockCrypto c') => ProtocolLedgerView (SimpleBlock (WithLeaderSchedule (Praos c)) c') where protocolLedgerView _ _ = () - anachronisticProtocolLedgerView _ _ _ = Just $ slotUnbounded () + anachronisticProtocolLedgerView _ _ _ = Just $ SB.unbounded () + {------------------------------------------------------------------------------- Compute relative stake -------------------------------------------------------------------------------} 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/test-util/Test/Util/TestBlock.hs b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs index 5070018748c..4cd04897860 100644 --- a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs @@ -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 @@ -159,7 +160,7 @@ instance UpdateLedger TestBlock where instance ProtocolLedgerView TestBlock where protocolLedgerView _ _ = () - anachronisticProtocolLedgerView _ _ _ = Just $ slotUnbounded () + anachronisticProtocolLedgerView _ _ _ = Just $ SB.unbounded () instance LedgerConfigView TestBlock where ledgerConfigView = const LedgerConfig From 8759bef5bc202c7a4a64ad0d3d20c42ad6b9dc1b Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 17:09:14 +0200 Subject: [PATCH 20/22] Add ticket references to TODOs --- ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs index b22aa2c32bf..f8b41c47ec2 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs @@ -476,7 +476,7 @@ instance ( Given Cardano.Block.HeaderHash ) => DemoHeader (ByronHeader ByronDemo.Config) where demoEncodeHeader = ByronDemo.encodeHeader demoDecodeHeader = ByronDemo.decodeHeader - demoBlockFetchSize = const 2000 -- TODO + demoBlockFetchSize = const 2000 -- TODO #593 instance ( Given Cardano.Block.HeaderHash , Given Cardano.ProtocolMagicId @@ -493,7 +493,7 @@ instance ( Given Cardano.Block.HeaderHash (ByronHeader ByronDemo.Config) where demoForgeBlock = ByronDemo.forgeBlock demoGetHeader = byronHeader - demoBlockMatchesHeader = \_hdr _blk -> True -- TODO + demoBlockMatchesHeader = \_hdr _blk -> True -- TODO #595 {------------------------------------------------------------------------------- Evidence that we can run all the supported demos From 0ef04ea9d607376a669d1255540daa2153f5adf8 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 30 May 2019 17:19:25 +0200 Subject: [PATCH 21/22] Add reference to ticket --- ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs index cc15f67486e..d0d0656ba57 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs @@ -52,6 +52,7 @@ class ( Show (LedgerState b) data family LedgerState b :: * data family LedgerError b :: * + -- | Static environment required for the ledger data family LedgerConfig b :: * -- | Apply a block header to the ledger state. @@ -67,6 +68,7 @@ class ( Show (LedgerState b) -- (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 From 096979f29c60d01436d4ac98150893addfce0111 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 30 May 2019 18:33:08 +0200 Subject: [PATCH 22/22] Include the NodeConfig in the consensus test output The `getCreator` method, which tells you which node produced a block, is used in the checks of some consensus tests. The `getCreator` method takes a `NodeConfig`, but we didn't have a `NodeConfig` in those testing contexts, so we were using `error` instead. This was "fine" because this `NodeConfig` is only really used for the real PBFT implementation, which is not used in the tests, only in the demo. However, using `error` here is dirty and might work for now, but that may change in the future. Fix this by letting the test setup function return the `NodeConfig` for each node in addition to its chain. This `NodeConfig` can then be passed to `getCreator`. Actually, `getCreator` would work with any `NodeConfig` from the test setup, regardless to which node its corresponds. This is because `getCreator` only reads data from the `NodeConfig` that is common to all nodes, no node-specific data is used. Nonetheless, it is nicer to use the `NodeConfig` that belongs to "correct" node. --- .../test-consensus/Test/Dynamic/BFT.hs | 11 +++-- .../test-consensus/Test/Dynamic/General.hs | 5 ++- .../Test/Dynamic/LeaderSchedule.hs | 20 +++++---- .../test-consensus/Test/Dynamic/Network.hs | 10 +++-- .../test-consensus/Test/Dynamic/PBFT.hs | 11 +++-- .../test-consensus/Test/Dynamic/Praos.hs | 45 ++++++++++--------- .../test-consensus/Test/Dynamic/Util.hs | 33 +++++++------- 7 files changed, 76 insertions(+), 59 deletions(-) diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs index 8e1c1d3e020..fe668f9dfbd 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs @@ -56,13 +56,16 @@ prop_simple_bft_convergence k numCoreNodes = numCoreNodes where isValid :: [NodeId] - -> Map NodeId (Chain (SimpleBlock DemoBFT SimpleBlockMockCrypto)) + -> 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 + -- 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 217408f68a5..dabfedbe023 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs @@ -31,6 +31,7 @@ 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 @@ -43,7 +44,7 @@ prop_simple_protocol_convergence :: forall p c. ) => (CoreNodeId -> ProtocolInfo (SimpleBlock p c)) -> ( [NodeId] - -> Map NodeId (Chain (SimpleBlock p c)) + -> Map NodeId (NodeConfig p, Chain (SimpleBlock p c)) -> Property) -> NumCoreNodes -> NumSlots @@ -67,7 +68,7 @@ test_simple_protocol_convergence :: forall m p c. ) => (CoreNodeId -> ProtocolInfo (SimpleBlock p c)) -> ( [NodeId] - -> Map NodeId (Chain (SimpleBlock p c)) + -> 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 c509745edef..16f73d03b1d 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs @@ -81,17 +81,21 @@ prop_simple_leader_schedule_convergence numSlots numCoreNodes params seed = numSlots seed where - nodeConfig = error "NodeConfig required in LeaderSchedule tests" isValid :: [NodeId] - -> Map NodeId (Chain (SimpleBlock DemoLeaderSchedule SimpleBlockMockCrypto)) + -> Map NodeId ( NodeConfig DemoLeaderSchedule + , Chain (SimpleBlock DemoLeaderSchedule SimpleBlockMockCrypto)) -> Property isValid nodeIds final = - counterexample (tracesToDot nodeConfig 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 c1cf5a23d93..df1fdb8b5d7 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs @@ -43,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 @@ -75,7 +76,7 @@ broadcastNetwork :: forall m p c. -> (CoreNodeId -> ProtocolInfo (SimpleBlock p c)) -> ChaChaDRG -> NumSlots - -> m (Map NodeId (Chain (SimpleBlock p c))) + -> m (Map NodeId (NodeConfig p, Chain (SimpleBlock p c))) broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do -- all known addresses @@ -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) diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs index f66deacb067..f5734ebf4a0 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs @@ -65,13 +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 (SimpleBlock DemoMockPBFT SimpleBlockMockCrypto)) + -> 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 + -- 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 99c8117a532..7427173d384 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs @@ -93,29 +93,30 @@ prop_simple_praos_convergence params numCoreNodes numSlots = PraosParams{..} = params isValid :: [NodeId] - -> Map NodeId (Chain (SimpleBlock DemoPraos SimpleBlockMockCrypto)) + -> Map NodeId ( NodeConfig DemoPraos + , Chain (SimpleBlock DemoPraos SimpleBlockMockCrypto)) -> Property - isValid nodeIds final = counterexample (show final) $ - -- Oh dear, oh dear. This node config isn't used except in the RealPBFT - -- case, and it's not available here, so we leave it undefined. But this - -- isn't especially nice, since there's nothing stopping somebody changing - -- things later to use it. All of this only exists in test code, though. - let nc = error "Node config missing for Praos protocol" - schedule = leaderScheduleFromTrace nc numSlots final - longest = longestCrowdedRun schedule - crowded = crowdedRunLength longest - in counterexample (tracesToDot nc 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 076d31ab105..d4f88f7109c 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs @@ -141,19 +141,19 @@ instance Labellable EdgeLabel where toLabelValue = const $ StrLabel Text.empty tracesToDot :: forall b. (HasHeader b, HasCreator b) - => NodeConfig (BlockProtocol b) - -> Map NodeId (Chain b) + => Map NodeId (NodeConfig (BlockProtocol b), Chain b) -> String -tracesToDot nc traces = Text.unpack $ printDotGraph $ graphToDot quickParams graph +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 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 @@ -164,8 +164,9 @@ tracesToDot nc traces = Text.unpack $ printDotGraph $ graphToDot quickParams gra 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 @@ -195,18 +196,20 @@ tracesToDot nc traces = Text.unpack $ printDotGraph $ graphToDot quickParams gra graph = mkGraph ns es leaderScheduleFromTrace :: forall b. (HasCreator b, HasHeader b) - => NodeConfig (BlockProtocol b) - -> NumSlots - -> Map NodeId (Chain b) + => NumSlots + -> Map NodeId (NodeConfig (BlockProtocol b), Chain b) -> LeaderSchedule -leaderScheduleFromTrace nc (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 nc 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