From 52a2a225e247baffb58dd92324bfce53535657c0 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Fri, 19 Jun 2020 11:43:16 +0200 Subject: [PATCH] Introduce ChainIndepState Closes #2058, #2229. * Get rid of the `TPraosForgeState` wrapper around `HotKey` and track more. information about the `HotKey`. * Rename `ConsensusState` to `ChainDepState`. * Introduce `ChainIndepState` and use it to track the `HotKey` for `TPraos`. * Rename `ForgeState` to `ExtraForgeState` (block-specific, unused, but for future use, e.g., hardware devices, online opcert renewal) and define `ForgeState` to be the product of `ChainIndepState` and `ExtraForgeState`. * Pass the `ChainIndepState` to `checkIsLeader` so that `TPraos` can check the validity of the KES key (original goal of this PR). * Remove `Update`. * Make `forgeBlock` pure by removing `MonadRandom` (work towards #2036). * Also remove `MonadRandom` from `ProtocolInfo`. --- .../Ouroboros/Consensus/ByronDual/Ledger.hs | 56 ++--- .../src/Ouroboros/Consensus/ByronDual/Node.hs | 1 + .../Consensus/ByronDual/Node/Serialisation.hs | 8 +- .../src/Test/Consensus/Byron/Examples.hs | 10 +- .../ThreadNet/Infra/Byron/TrackUpdates.hs | 3 +- .../test/Test/Consensus/Byron/Golden.hs | 12 +- .../test/Test/ThreadNet/RealPBFT.hs | 2 +- .../Ouroboros/Consensus/Byron/Ledger/Forge.hs | 22 +- .../Consensus/Byron/Ledger/Ledger.hs | 4 +- .../Ouroboros/Consensus/Byron/Ledger/PBFT.hs | 16 +- .../src/Ouroboros/Consensus/Byron/Node.hs | 1 + .../Consensus/Byron/Node/Serialisation.hs | 8 +- .../src/Ouroboros/Consensus/Cardano.hs | 4 +- .../Consensus/Cardano/CanHardFork.hs | 20 +- .../src/Ouroboros/Consensus/Cardano/Node.hs | 19 +- .../test/Test/Consensus/Cardano/Generators.hs | 10 +- .../test/Test/ThreadNet/Cardano.hs | 2 +- .../src/Test/Consensus/Shelley/Examples.hs | 6 +- .../src/Test/ThreadNet/Infra/Shelley.hs | 8 +- .../test/Test/Consensus/Shelley/Golden.hs | 8 +- .../ouroboros-consensus-shelley.cabal | 1 + .../Consensus/Shelley/Ledger/Forge.hs | 81 +------ .../Consensus/Shelley/Ledger/Ledger.hs | 2 +- .../src/Ouroboros/Consensus/Shelley/Node.hs | 51 ++--- .../Consensus/Shelley/Node/Serialisation.hs | 4 +- .../Ouroboros/Consensus/Shelley/Protocol.hs | 147 +++++++------ .../Consensus/Shelley/Protocol/Crypto.hs | 17 -- .../Shelley/Protocol/Crypto/HotKey.hs | 111 ++++++++++ .../Consensus/Mock/Ledger/Block/BFT.hs | 3 +- .../Consensus/Mock/Ledger/Block/PBFT.hs | 3 +- .../Consensus/Mock/Ledger/Block/Praos.hs | 29 ++- .../Consensus/Mock/Ledger/Block/PraosRule.hs | 3 +- .../Ouroboros/Consensus/Mock/Ledger/Forge.hs | 16 +- .../Ouroboros/Consensus/Mock/Node/Abstract.hs | 4 +- .../src/Ouroboros/Consensus/Mock/Node/BFT.hs | 1 + .../src/Ouroboros/Consensus/Mock/Node/PBFT.hs | 1 + .../Ouroboros/Consensus/Mock/Node/Praos.hs | 17 +- .../Consensus/Mock/Node/PraosRule.hs | 4 +- .../Consensus/Mock/Protocol/Praos.hs | 62 +++--- .../src/Test/ThreadNet/Network.hs | 35 ++-- .../src/Test/ThreadNet/Rekeying.hs | 3 +- .../Test/ThreadNet/Util/BlockProduction.hs | 59 +++--- .../src/Test/Util/Serialisation.hs | 8 +- .../src/Test/Util/TestBlock.hs | 1 + ouroboros-consensus/src/Data/SOP/Strict.hs | 14 ++ .../src/Ouroboros/Consensus/Block/Forge.hs | 197 +++++++++++------- .../src/Ouroboros/Consensus/Config.hs | 23 +- .../Consensus/HardFork/Combinator.hs | 11 +- .../HardFork/Combinator/AcrossEras.hs | 61 ++++-- .../Consensus/HardFork/Combinator/Basics.hs | 42 +++- .../HardFork/Combinator/Degenerate.hs | 67 +++--- .../Consensus/HardFork/Combinator/Forge.hs | 99 +++++---- .../Consensus/HardFork/Combinator/Protocol.hs | 89 ++++---- .../Combinator/Serialisation/SerialiseDisk.hs | 10 +- .../HardFork/Combinator/Translation.hs | 12 +- .../Consensus/HardFork/Combinator/Unary.hs | 73 +++++-- .../HardFork/Combinator/Util/Telescope.hs | 2 +- .../Ouroboros/Consensus/HeaderValidation.hs | 50 ++--- .../src/Ouroboros/Consensus/Ledger/Dual.hs | 1 + .../Ouroboros/Consensus/Ledger/Extended.hs | 18 +- .../MiniProtocol/ChainSync/Client.hs | 7 +- .../Consensus/Node/BlockProduction.hs | 51 +++-- .../Ouroboros/Consensus/Node/ProtocolInfo.hs | 6 +- .../src/Ouroboros/Consensus/Node/Tracers.hs | 2 +- .../Ouroboros/Consensus/Protocol/Abstract.hs | 91 ++++++-- .../src/Ouroboros/Consensus/Protocol/BFT.hs | 31 +-- .../Consensus/Protocol/LeaderSchedule.hs | 23 +- .../Consensus/Protocol/ModChainSel.hs | 35 ++-- .../src/Ouroboros/Consensus/Protocol/PBFT.hs | 21 +- .../Consensus/Protocol/PBFT/State.hs | 10 +- .../Consensus/Storage/ChainDB/Impl/LgrDB.hs | 4 +- .../Storage/ChainDB/Serialisation.hs | 12 +- .../Ouroboros/Consensus/TypeFamilyWrappers.hs | 96 +++++---- .../src/Ouroboros/Consensus/Util.hs | 39 +++- .../Test/Consensus/HardFork/Combinator.hs | 27 ++- .../Test/Consensus/HardFork/Combinator/A.hs | 27 +-- .../Test/Consensus/HardFork/Combinator/B.hs | 27 +-- .../MiniProtocol/ChainSync/Client.hs | 1 + .../MiniProtocol/LocalStateQuery/Server.hs | 1 + .../Ouroboros/Storage/ChainDB/StateMachine.hs | 2 +- .../Ouroboros/Storage/LedgerDB/InMemory.hs | 2 +- .../Test/Ouroboros/Storage/TestBlock.hs | 3 +- 82 files changed, 1269 insertions(+), 901 deletions(-) create mode 100644 ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto/HotKey.hs diff --git a/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Ledger.hs b/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Ledger.hs index 387fd3c0a32..90f34cf927f 100644 --- a/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Ledger.hs +++ b/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Ledger.hs @@ -25,7 +25,6 @@ module Ouroboros.Consensus.ByronDual.Ledger ( ) where import Codec.Serialise -import Crypto.Random (MonadRandom) import Data.ByteString (ByteString) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -208,20 +207,20 @@ bridgeTransactionIds = Spec.Test.transactionIds -------------------------------------------------------------------------------} instance CanForge DualByronBlock where - type ForgeState DualByronBlock = ForgeState ByronBlock + type ExtraForgeState DualByronBlock = ExtraForgeState ByronBlock forgeBlock = forgeDualByronBlock forgeDualByronBlock - :: forall m. (MonadRandom m, HasCallStack) + :: HasCallStack => TopLevelConfig DualByronBlock -> ForgeState DualByronBlock -> BlockNo -- ^ Current block number -> TickedLedgerState DualByronBlock -- ^ Ledger -> [GenTx DualByronBlock] -- ^ Txs to add in the block -> PBftIsLeader PBftByronCrypto -- ^ Leader proof ('IsLeader') - -> m DualByronBlock -forgeDualByronBlock cfg () curBlockNo tickedLedger txs isLeader = do + -> DualByronBlock +forgeDualByronBlock cfg forgeState curBlockNo tickedLedger txs isLeader = -- NOTE: We do not /elaborate/ the real Byron block from the spec one, but -- instead we /forge/ it. This is important, because we want to test that -- codepath. This does mean that we do not get any kind of "bridge" between @@ -229,32 +228,33 @@ forgeDualByronBlock cfg () curBlockNo tickedLedger txs isLeader = do -- the block instead). Fortunately, this is okay, since the bridge for the -- block can be computed from the bridge information of all of the txs. - main <- forgeByronBlock - (dualTopLevelConfigMain cfg) - () - curBlockNo - (Ticked { - tickedSlotNo = curSlotNo - , tickedLedgerState = dualLedgerStateMain $ - tickedLedgerState tickedLedger - }) - (map dualGenTxMain txs) - isLeader - - let aux :: ByronSpecBlock - aux = forgeByronSpecBlock - curSlotNo - curBlockNo - (dualLedgerStateAux $ tickedLedgerState tickedLedger) - (map dualGenTxAux txs) - (bridgeToSpecKey - (dualLedgerStateBridge $ tickedLedgerState tickedLedger) - (hashVerKey . deriveVerKeyDSIGN . pbftSignKey $ isLeader)) - - return DualBlock { + DualBlock { dualBlockMain = main , dualBlockAux = Just aux , dualBlockBridge = mconcat $ map dualGenTxBridge txs } where curSlotNo = tickedSlotNo tickedLedger + + main :: ByronBlock + main = forgeByronBlock + (dualTopLevelConfigMain cfg) + (castForgeState forgeState) + curBlockNo + (Ticked { + tickedSlotNo = curSlotNo + , tickedLedgerState = dualLedgerStateMain $ + tickedLedgerState tickedLedger + }) + (map dualGenTxMain txs) + isLeader + + aux :: ByronSpecBlock + aux = forgeByronSpecBlock + curSlotNo + curBlockNo + (dualLedgerStateAux $ tickedLedgerState tickedLedger) + (map dualGenTxAux txs) + (bridgeToSpecKey + (dualLedgerStateBridge $ tickedLedgerState tickedLedger) + (hashVerKey . deriveVerKeyDSIGN . pbftSignKey $ isLeader)) diff --git a/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node.hs index 0a079325af8..fb7bef08e4a 100644 --- a/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node.hs @@ -73,6 +73,7 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params mLeader = configConsensus = PBftConfig { pbftParams = params } + , configIndep = () , configLedger = DualLedgerConfig { dualLedgerConfigMain = concreteGenesis , dualLedgerConfigAux = abstractConfig diff --git a/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs b/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs index cef3c3f4192..f6224d6a82f 100644 --- a/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs +++ b/ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs @@ -77,12 +77,12 @@ instance EncodeDisk DualByronBlock (LedgerState DualByronBlock) where instance DecodeDisk DualByronBlock (LedgerState DualByronBlock) where decodeDisk _ = decodeDualLedgerState decodeByronLedgerState --- | @'ConsensusState' ('BlockProtocol' 'DualByronBlock')@ +-- | @'ChainDepState' ('BlockProtocol' 'DualByronBlock')@ instance EncodeDisk DualByronBlock (PBftState PBftByronCrypto) where - encodeDisk _ = encodeByronConsensusState --- | @'ConsensusState' ('BlockProtocol' 'DualByronBlock')@ + encodeDisk _ = encodeByronChainDepState +-- | @'ChainDepState' ('BlockProtocol' 'DualByronBlock')@ instance DecodeDisk DualByronBlock (PBftState PBftByronCrypto) where - decodeDisk ccfg = decodeByronConsensusState k + decodeDisk ccfg = decodeByronChainDepState k where k = getByronSecurityParam $ dualCodecConfigMain ccfg diff --git a/ouroboros-consensus-byron-test/src/Test/Consensus/Byron/Examples.hs b/ouroboros-consensus-byron-test/src/Test/Consensus/Byron/Examples.hs index 1d44179676e..600e6ba59ec 100644 --- a/ouroboros-consensus-byron-test/src/Test/Consensus/Byron/Examples.hs +++ b/ouroboros-consensus-byron-test/src/Test/Consensus/Byron/Examples.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Test.Consensus.Byron.Examples ( - exampleConsensusState + exampleChainDepState , exampleLedgerState , exampleHeaderState , exampleExtLedgerState @@ -48,7 +48,7 @@ import qualified Test.Cardano.Chain.UTxO.Example as CC -------------------------------------------------------------------------------} -- | Note that we must use the same value for the 'SecurityParam' as for the --- 'S.WindowSize', because 'decodeByronConsensusState' only takes the +-- 'S.WindowSize', because 'decodeByronChainDepState' only takes the -- 'SecurityParam' and uses it as the basis for the 'S.WindowSize'. secParam :: SecurityParam secParam = SecurityParam 2 @@ -60,8 +60,8 @@ windowSize = S.WindowSize 2 Examples -------------------------------------------------------------------------------} -exampleConsensusState :: ConsensusState (BlockProtocol ByronBlock) -exampleConsensusState = withEBB +exampleChainDepState :: ChainDepState (BlockProtocol ByronBlock) +exampleChainDepState = withEBB where signers = map (`S.PBftSigner` CC.exampleKeyHash) [1..4] @@ -75,7 +75,7 @@ exampleConsensusState = withEBB exampleEbbHeaderHashBytes :: HeaderHashBytes exampleEbbSlot = 6 exampleEbbHeaderHashBytes = mkHeaderHashBytesForTestingOnly - (Lazy8.pack "test_golden_ConsensusState6") + (Lazy8.pack "test_golden_ChainDepState6") withEBB = S.appendEBB secParam windowSize exampleEbbSlot exampleEbbHeaderHashBytes diff --git a/ouroboros-consensus-byron-test/src/Test/ThreadNet/Infra/Byron/TrackUpdates.hs b/ouroboros-consensus-byron-test/src/Test/ThreadNet/Infra/Byron/TrackUpdates.hs index 61a09bd9285..bb99b1f9f61 100644 --- a/ouroboros-consensus-byron-test/src/Test/ThreadNet/Infra/Byron/TrackUpdates.hs +++ b/ouroboros-consensus-byron-test/src/Test/ThreadNet/Infra/Byron/TrackUpdates.hs @@ -59,7 +59,6 @@ import Test.ThreadNet.Util.NodeTopology import Test.ThreadNet.Infra.Byron.ProtocolInfo -import Test.Util.Random import Test.Util.Slots (NumSlots (..)) -- | The expectation and observation regarding whether the hard-fork proposal @@ -389,7 +388,7 @@ mkProtocolRealPBftAndHardForkTxs ProtocolInfo{pInfoConfig} = pInfo TopLevelConfig{configBlock} = pInfoConfig - pInfo :: ProtocolInfo (ChaChaT m) ByronBlock + pInfo :: ProtocolInfo m ByronBlock pInfo = mkProtocolRealPBFT params cid genesisConfig genesisSecrets proposals :: [Byron.GenTx ByronBlock] diff --git a/ouroboros-consensus-byron-test/test/Test/Consensus/Byron/Golden.hs b/ouroboros-consensus-byron-test/test/Test/Consensus/Byron/Golden.hs index e8f5da3c2cc..387199bcdd0 100644 --- a/ouroboros-consensus-byron-test/test/Test/Consensus/Byron/Golden.hs +++ b/ouroboros-consensus-byron-test/test/Test/Consensus/Byron/Golden.hs @@ -32,7 +32,7 @@ tests :: TestTree tests = testGroup "Golden tests" -- Note that for most Byron types, we simply wrap the en/decoders from -- cardano-ledger, which already has golden tests for them. - [ testCase "ConsensusState" test_golden_ConsensusState + [ testCase "ChainDepState" test_golden_ChainDepState , testCase "LedgerState" test_golden_LedgerState , testCase "GenTxId" test_golden_GenTxId , testCase "UPIState" test_golden_UPIState @@ -46,10 +46,10 @@ tests = testGroup "Golden tests" , testCase "Result" test_golden_Result ] -test_golden_ConsensusState :: Assertion -test_golden_ConsensusState = goldenTestCBOR - encodeByronConsensusState - exampleConsensusState +test_golden_ChainDepState :: Assertion +test_golden_ChainDepState = goldenTestCBOR + encodeByronChainDepState + exampleChainDepState [ TkListLen 2 , TkInt 0 , TkListLen 3 @@ -73,7 +73,7 @@ test_golden_ConsensusState = goldenTestCBOR , TkListLen 4 , TkInt 0 , TkInt 6 - , TkBytes "test_golden_ConsensusState6" + , TkBytes "test_golden_ChainDepState6" , TkListLen 2 , TkInt 1 , TkInt 4 diff --git a/ouroboros-consensus-byron-test/test/Test/ThreadNet/RealPBFT.hs b/ouroboros-consensus-byron-test/test/Test/ThreadNet/RealPBFT.hs index 387409e7048..d5c38904275 100644 --- a/ouroboros-consensus-byron-test/test/Test/ThreadNet/RealPBFT.hs +++ b/ouroboros-consensus-byron-test/test/Test/ThreadNet/RealPBFT.hs @@ -1282,7 +1282,7 @@ genNodeRekeys params nodeJoinPlan nodeTopology numSlots@(NumSlots t) mkRekeyUpd :: Genesis.Config -> Genesis.GeneratedSecrets - -> ProtocolInfo (ChaChaT m) ByronBlock + -> ProtocolInfo m ByronBlock -> EpochNo -> Crypto.SignKeyDSIGN Crypto.ByronDSIGN -> Maybe (TestNodeInitialization m ByronBlock) diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Forge.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Forge.hs index ad8730376c3..a4715cba4d2 100644 --- a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Forge.hs +++ b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Forge.hs @@ -44,18 +44,17 @@ import Ouroboros.Consensus.Byron.Ledger.PBFT import Ouroboros.Consensus.Byron.Protocol instance CanForge ByronBlock where - type ForgeState ByronBlock = () forgeBlock = forgeByronBlock forgeByronBlock - :: forall m. (Monad m, HasCallStack) + :: HasCallStack => TopLevelConfig ByronBlock -> ForgeState ByronBlock -> BlockNo -- ^ Current block number -> TickedLedgerState ByronBlock -- ^ Current ledger -> [GenTx ByronBlock] -- ^ Txs to add in the block -> PBftIsLeader PBftByronCrypto -- ^ Leader proof ('IsLeader') - -> m ByronBlock + -> ByronBlock forgeByronBlock = forgeRegularBlock forgeEBB @@ -126,21 +125,20 @@ initBlockPayloads = BlockPayloads } forgeRegularBlock - :: forall m. (Monad m, HasCallStack) + :: HasCallStack => TopLevelConfig ByronBlock -> ForgeState ByronBlock -> BlockNo -- ^ Current block number -> TickedLedgerState ByronBlock -- ^ Current ledger -> [GenTx ByronBlock] -- ^ Txs to add in the block -> PBftIsLeader PBftByronCrypto -- ^ Leader proof ('IsLeader') - -> m ByronBlock -forgeRegularBlock cfg () curNo tickedLedger txs isLeader = - let ouroborosPayload = - forgePBftFields - (mkByronContextDSIGN $ configBlock cfg) - isLeader - (reAnnotate $ Annotated toSign ()) - in return $ forge ouroborosPayload + -> ByronBlock +forgeRegularBlock cfg _forgeState curNo tickedLedger txs isLeader = + forge $ + forgePBftFields + (mkByronContextDSIGN $ configBlock cfg) + isLeader + (reAnnotate $ Annotated toSign ()) where curSlot :: SlotNo curSlot = tickedSlotNo tickedLedger diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index 0fef1322c5d..1ae8d43e2ad 100644 --- a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -354,12 +354,12 @@ decodeByronAnnTip = decodeAnnTipIsEBB decodeByronHeaderHash encodeByronExtLedgerState :: ExtLedgerState ByronBlock -> Encoding encodeByronExtLedgerState = encodeExtLedgerState encodeByronLedgerState - encodeByronConsensusState + encodeByronChainDepState encodeByronAnnTip encodeByronHeaderState :: HeaderState ByronBlock -> Encoding encodeByronHeaderState = encodeHeaderState - encodeByronConsensusState + encodeByronChainDepState encodeByronAnnTip encodeByronLedgerState :: LedgerState ByronBlock -> Encoding diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/PBFT.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/PBFT.hs index 312f9d3892e..dc5be871c9d 100644 --- a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/PBFT.hs +++ b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/PBFT.hs @@ -9,8 +9,8 @@ module Ouroboros.Consensus.Byron.Ledger.PBFT ( toPBftLedgerView , fromPBftLedgerView - , encodeByronConsensusState - , decodeByronConsensusState + , encodeByronChainDepState + , decodeByronChainDepState , mkByronContextDSIGN ) where @@ -84,12 +84,12 @@ toPBftLedgerView = PBftLedgerView . Delegation.unMap fromPBftLedgerView :: PBftLedgerView PBftByronCrypto -> Delegation.Map fromPBftLedgerView = Delegation.Map . pbftDelegates -encodeByronConsensusState - :: ConsensusState (BlockProtocol ByronBlock) +encodeByronChainDepState + :: ChainDepState (BlockProtocol ByronBlock) -> Encoding -encodeByronConsensusState = S.encodePBftState +encodeByronChainDepState = S.encodePBftState -decodeByronConsensusState +decodeByronChainDepState :: SecurityParam - -> Decoder s (ConsensusState (BlockProtocol ByronBlock)) -decodeByronConsensusState k = S.decodePBftState k (pbftWindowSize k) + -> Decoder s (ChainDepState (BlockProtocol ByronBlock)) +decodeByronChainDepState k = S.decodePBftState k (pbftWindowSize k) diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node.hs index fbfd3fdeb10..0fa4d43dd9b 100644 --- a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node.hs @@ -125,6 +125,7 @@ protocolInfoByron genesisConfig mSigThresh pVer sVer mLeader = configConsensus = PBftConfig { pbftParams = byronPBftParams genesisConfig mSigThresh } + , configIndep = () , configLedger = genesisConfig , configBlock = byronConfig } diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node/Serialisation.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node/Serialisation.hs index 6e16211e3c1..8a2e4516a1b 100644 --- a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node/Serialisation.hs +++ b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node/Serialisation.hs @@ -56,12 +56,12 @@ instance EncodeDisk ByronBlock (LedgerState ByronBlock) where instance DecodeDisk ByronBlock (LedgerState ByronBlock) where decodeDisk _ = decodeByronLedgerState --- | @'ConsensusState' ('BlockProtocol' 'ByronBlock')@ +-- | @'ChainDepState' ('BlockProtocol' 'ByronBlock')@ instance EncodeDisk ByronBlock (PBftState PBftByronCrypto) where - encodeDisk _ = encodeByronConsensusState --- | @'ConsensusState' ('BlockProtocol' 'ByronBlock')@ + encodeDisk _ = encodeByronChainDepState +-- | @'ChainDepState' ('BlockProtocol' 'ByronBlock')@ instance DecodeDisk ByronBlock (PBftState PBftByronCrypto) where - decodeDisk ccfg = decodeByronConsensusState (getByronSecurityParam ccfg) + decodeDisk ccfg = decodeByronChainDepState (getByronSecurityParam ccfg) instance EncodeDisk ByronBlock (AnnTip ByronBlock) where encodeDisk _ = encodeByronAnnTip diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs index d2020acfb1e..ae81218aba4 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs @@ -31,7 +31,6 @@ module Ouroboros.Consensus.Cardano ( , verifyProtocolClient ) where -import Crypto.Random (MonadRandom) import Data.Type.Equality import Cardano.Prelude (Natural) @@ -51,6 +50,7 @@ import Ouroboros.Consensus.Protocol.BFT as X import Ouroboros.Consensus.Protocol.LeaderSchedule as X import Ouroboros.Consensus.Protocol.PBFT as X import Ouroboros.Consensus.Util +import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.HardFork.Combinator @@ -189,7 +189,7 @@ verifyProtocol ProtocolCardano{} = Refl -------------------------------------------------------------------------------} -- | Data required to run the selected protocol -protocolInfo :: forall m blk p. MonadRandom m +protocolInfo :: forall m blk p. IOLike m => Protocol m blk p -> ProtocolInfo m blk protocolInfo (ProtocolMockBFT nodes nid k paramsEra) = protocolInfoBft nodes nid k paramsEra diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs index 662f7ded91d..18f77ef8d87 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -296,9 +296,9 @@ instance TPraosCrypto sc => HasPartialLedgerConfig (ShelleyBlock sc) where instance TPraosCrypto c => CanHardFork (CardanoEras c) where hardForkEraTranslation = EraTranslation { - translateLedgerState = PCons translateLedgerStateByronToShelleyWrapper PNil - , translateLedgerView = PCons translateLedgerViewByronToShelleyWrapper PNil - , translateConsensusState = PCons translateConsensusStateByronToShelleyWrapper PNil + translateLedgerState = PCons translateLedgerStateByronToShelleyWrapper PNil + , translateLedgerView = PCons translateLedgerViewByronToShelleyWrapper PNil + , translateChainDepState = PCons translateChainDepStateByronToShelleyWrapper PNil } {------------------------------------------------------------------------------- @@ -452,22 +452,22 @@ translateLedgerStateByronToShelley cfgShelley epochNo ledgerByron = (Map.keysSet (sgGenDelegs genesisShelley)) (sgProtocolParams genesisShelley) -translateConsensusStateByronToShelleyWrapper +translateChainDepStateByronToShelleyWrapper :: forall sc. RequiringBoth WrapConsensusConfig - (Translate WrapConsensusState) + (Translate WrapChainDepState) ByronBlock (ShelleyBlock sc) -translateConsensusStateByronToShelleyWrapper = - RequireBoth $ \_ _ -> Translate $ \_ (WrapConsensusState pbftState) -> - WrapConsensusState (translateConsensusStateByronToShelley pbftState) +translateChainDepStateByronToShelleyWrapper = + RequireBoth $ \_ _ -> Translate $ \_ (WrapChainDepState pbftState) -> + WrapChainDepState (translateChainDepStateByronToShelley pbftState) -translateConsensusStateByronToShelley +translateChainDepStateByronToShelley :: forall bc sc. PBftState bc -> TPraosState sc -translateConsensusStateByronToShelley pbftState = +translateChainDepStateByronToShelley pbftState = TPraosState.empty (PBftState.tipSlot pbftState) $ SL.PrtclState Map.empty diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs index fffee0e9aca..e39b72c19bd 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs @@ -29,7 +29,6 @@ import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) import qualified Codec.CBOR.Encoding as CBOR import Control.Exception (assert) -import Crypto.Random (MonadRandom) import qualified Data.ByteString.Short as Short import Data.Functor.Contravariant (contramap) import qualified Data.List.NonEmpty as NE @@ -57,6 +56,7 @@ import Ouroboros.Consensus.Storage.Common (BinaryBlockInfo (..)) import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Counting (exactlyTwo) +import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.SOP (OptNP (..)) import Ouroboros.Consensus.HardFork.Combinator @@ -276,7 +276,7 @@ instance TPraosCrypto sc => RunNode (CardanoBlock sc) where -------------------------------------------------------------------------------} protocolInfoCardano - :: forall sc m. (MonadRandom m, TPraosCrypto sc) + :: forall sc m. (IOLike m, TPraosCrypto sc) -- Byron => Genesis.Config -> Maybe PBftSignatureThreshold @@ -302,7 +302,7 @@ protocolInfoCardano genesisByron mSigThresh pVer sVer mbCredsByron initHardForkState initLedgerStateByron , headerState = genesisHeaderState $ initHardForkState - (WrapConsensusState initConsensusStateByron) + (WrapChainDepState initChainDepStateByron) } , pInfoLeaderCreds = creds } @@ -317,7 +317,7 @@ protocolInfoCardano genesisByron mSigThresh pVer sVer mbCredsByron , pInfoInitLedger = ExtLedgerState { ledgerState = initLedgerStateByron , headerState = HeaderState { - headerStateConsensus = initConsensusStateByron + headerStateConsensus = initChainDepStateByron } } } = protocolInfoByron @m genesisByron mSigThresh pVer sVer mbCredsByron @@ -336,11 +336,14 @@ protocolInfoCardano genesisByron mSigThresh pVer sVer mbCredsByron -- Shelley + tpraosParams :: TPraosParams + tpraosParams = Shelley.mkTPraosParams maxMajorPV genesisShelley + blockConfigShelley :: BlockConfig (ShelleyBlock sc) blockConfigShelley = Shelley.mkShelleyBlockConfig protVer genesisShelley partialConsensusConfigShelley :: PartialConsensusConfig (BlockProtocol (ShelleyBlock sc)) - partialConsensusConfigShelley = Shelley.mkTPraosParams maxMajorPV genesisShelley + partialConsensusConfigShelley = tpraosParams partialLedgerConfigShelley :: PartialLedgerConfig (ShelleyBlock sc) partialLedgerConfigShelley = ShelleyPartialLedgerConfig { @@ -377,6 +380,11 @@ protocolInfoCardano genesisByron mSigThresh pVer sVer mbCredsByron :* Nil ) } + , configIndep = PerEraChainIndepStateConfig + ( WrapChainIndepStateConfig () + :* WrapChainIndepStateConfig tpraosParams + :* Nil + ) , configLedger = HardForkLedgerConfig { hardForkLedgerConfigK = k , hardForkLedgerConfigShape = shape @@ -459,5 +467,6 @@ projByronTopLevelConfig cfg = byronCfg byronCfg = TopLevelConfig { configBlock = byronBlockCfg , configConsensus = byronConsensusCfg + , configIndep = () , configLedger = byronLedgerConfig byronLedgerCfg } diff --git a/ouroboros-consensus-cardano/test/Test/Consensus/Cardano/Generators.hs b/ouroboros-consensus-cardano/test/Test/Consensus/Cardano/Generators.hs index b49845a1399..3f6edc003f8 100644 --- a/ouroboros-consensus-cardano/test/Test/Consensus/Cardano/Generators.hs +++ b/ouroboros-consensus-cardano/test/Test/Consensus/Cardano/Generators.hs @@ -109,13 +109,13 @@ instance (sc ~ TPraosMockCrypto h, HashAlgorithm h, forall a. Arbitrary (Hash h arbitrary = arbitraryHardForkState (Proxy @LedgerState) instance (sc ~ TPraosMockCrypto h, HashAlgorithm h) - => Arbitrary (HardForkConsensusState (CardanoEras sc)) where - arbitrary = arbitraryHardForkState (Proxy @WrapConsensusState) + => Arbitrary (HardForkChainDepState (CardanoEras sc)) where + arbitrary = arbitraryHardForkState (Proxy @WrapChainDepState) -- | Forwarding -instance Arbitrary (ConsensusState (BlockProtocol blk)) - => Arbitrary (WrapConsensusState blk) where - arbitrary = WrapConsensusState <$> arbitrary +instance Arbitrary (ChainDepState (BlockProtocol blk)) + => Arbitrary (WrapChainDepState blk) where + arbitrary = WrapChainDepState <$> arbitrary -- | NOTE: Byron hashes are always 32 bytes, but for Shelley it depends on the -- crypto: with 'TPraosStandardCrypto' the hash is also 32 bytes, but with diff --git a/ouroboros-consensus-cardano/test/Test/ThreadNet/Cardano.hs b/ouroboros-consensus-cardano/test/Test/ThreadNet/Cardano.hs index b177e2bf271..aee45e8adb6 100644 --- a/ouroboros-consensus-cardano/test/Test/ThreadNet/Cardano.hs +++ b/ouroboros-consensus-cardano/test/Test/ThreadNet/Cardano.hs @@ -316,7 +316,7 @@ mkProtocolCardanoAndHardForkTxs generatedSecretsByron propPV - pInfo :: ProtocolInfo (ChaChaT m) (CardanoBlock sc) + pInfo :: ProtocolInfo m (CardanoBlock sc) pInfo = protocolInfoCardano -- Byron genesisByron diff --git a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs index 611218d2b07..7b8b9eca033 100644 --- a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs @@ -15,7 +15,7 @@ module Test.Consensus.Shelley.Examples ( , exampleGenTx , exampleGenTxId , exampleApplyTxErr - , exampleConsensusState + , exampleChainDepState , exampleLedgerState , exampleHeaderState , exampleExtLedgerState @@ -131,8 +131,8 @@ exampleApplyTxErr = $ STS.UtxowFailure $ STS.InvalidWitnessesUTXOW [SL.VKey 1] -exampleConsensusState :: ConsensusState (BlockProtocol (Block ShortHash)) -exampleConsensusState = +exampleChainDepState :: ChainDepState (BlockProtocol (Block ShortHash)) +exampleChainDepState = TPraosState.append 2 (mkPrtclState 2) $ TPraosState.empty (At 1) (mkPrtclState 1) where diff --git a/ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs b/ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs index 80e9a650d0c..f02f11ad999 100644 --- a/ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs @@ -38,6 +38,7 @@ import Cardano.Slotting.Slot (EpochSize (..)) import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Util.IOLike import Test.Util.Orphans.Arbitrary () import Test.Util.Random @@ -56,8 +57,7 @@ import qualified Shelley.Spec.Ledger.TxData as SL import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Shelley.Protocol -import Ouroboros.Consensus.Shelley.Protocol.Crypto (DSIGN, - HotKey (..)) +import Ouroboros.Consensus.Shelley.Protocol.Crypto (DSIGN) import Test.Consensus.Shelley.MockCrypto (TPraosMockCrypto) import qualified Test.Shelley.Spec.Ledger.Generator.Core as Gen @@ -150,7 +150,7 @@ genCoreNode startKESPeriod = do mkLeaderCredentials :: TPraosCrypto c => CoreNode c -> TPraosLeaderCredentials c mkLeaderCredentials CoreNode { cnDelegateKey, cnVRF, cnKES, cnOCert } = TPraosLeaderCredentials { - tpraosLeaderCredentialsSignKey = HotKey 0 cnKES + tpraosLeaderCredentialsSignKey = cnKES , tpraosLeaderCredentialsIsCoreNode = TPraosIsCoreNode { tpraosIsCoreNodeOpCert = cnOCert , tpraosIsCoreNodeColdVerKey = SL.VKey $ deriveVerKeyDSIGN cnDelegateKey @@ -287,7 +287,7 @@ mkGenesisConfig pVer k d slotLength maxKESEvolutions coreNodes = mkCredential = SL.KeyHashObj . SL.hashKey . SL.VKey . deriveVerKeyDSIGN mkProtocolRealTPraos - :: forall m c. (MonadRandom m, TPraosCrypto c) + :: forall m c. (IOLike m, TPraosCrypto c) => ShelleyGenesis c -> CoreNode c -> ProtocolInfo m (ShelleyBlock c) diff --git a/ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Golden.hs b/ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Golden.hs index 6a91886066e..d746c5f5a8b 100644 --- a/ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Golden.hs +++ b/ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Golden.hs @@ -40,7 +40,7 @@ import Test.Consensus.Shelley.MockCrypto tests :: TestTree tests = testGroup "Golden tests" - [ testCase "ConsensusState" test_golden_ConsensusState + [ testCase "ChainDepState" test_golden_ChainDepState , testCase "LedgerState" test_golden_LedgerState , testCase "HeaderState" test_golden_HeaderState , testCase "ExtLedgerState" test_golden_ExtLedgerState @@ -206,10 +206,10 @@ testResults = testGroup "Results" goldenTestResult :: Query (Block ShortHash) result -> result -> FlatTerm -> Assertion goldenTestResult q = goldenTestCBOR (encodeShelleyResult q) -test_golden_ConsensusState :: Assertion -test_golden_ConsensusState = goldenTestCBOR +test_golden_ChainDepState :: Assertion +test_golden_ChainDepState = goldenTestCBOR toCBOR - exampleConsensusState + exampleChainDepState [ TkListLen 2 , TkInt 0 , TkListLen 2 diff --git a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal index 6c2a106170b..fd8bd84b3c2 100644 --- a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal +++ b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal @@ -41,6 +41,7 @@ library Ouroboros.Consensus.Shelley.Protocol Ouroboros.Consensus.Shelley.Protocol.State Ouroboros.Consensus.Shelley.Protocol.Crypto + Ouroboros.Consensus.Shelley.Protocol.Crypto.HotKey Ouroboros.Consensus.Shelley.Protocol.Util build-depends: base >=4.9 && <4.13 diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index 9acf859d3f0..d0624844beb 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} @@ -14,23 +13,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Shelley.Ledger.Forge ( - -- * ForgeState - TPraosForgeState (..) - -- * Forging - , forgeShelleyBlock - -- * Updating the state - , evolveKESKeyIfNecessary + forgeShelleyBlock ) where import Control.Exception -import Crypto.Random (MonadRandom) -import Data.Proxy (Proxy (..)) import qualified Data.Sequence.Strict as Seq -import Data.Typeable (typeRep) -import GHC.Generics (Generic) -import qualified Cardano.Crypto.KES.Class as KES -import Cardano.Prelude (NoUnexpectedThunks (..)) import Cardano.Slotting.Block import Ouroboros.Network.Block (castHash) @@ -41,98 +29,43 @@ import Ouroboros.Consensus.Ledger.Abstract import qualified Shelley.Spec.Ledger.BlockChain as SL import qualified Shelley.Spec.Ledger.Keys as SL -import qualified Shelley.Spec.Ledger.OCert as SL import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config import Ouroboros.Consensus.Shelley.Ledger.Integrity import Ouroboros.Consensus.Shelley.Ledger.Mempool import Ouroboros.Consensus.Shelley.Protocol -import Ouroboros.Consensus.Shelley.Protocol.Crypto {------------------------------------------------------------------------------- CanForge -------------------------------------------------------------------------------} instance TPraosCrypto c => CanForge (ShelleyBlock c) where - type ForgeState (ShelleyBlock c) = TPraosForgeState c forgeBlock = forgeShelleyBlock -{------------------------------------------------------------------------------- - ForgeState --------------------------------------------------------------------------------} - --- | This is the state containing the private key corresponding to the public --- key that Praos uses to verify headers. That is why we call it --- 'TPraosForgeState' instead of 'ShelleyForgeState'. -data TPraosForgeState c = TPraosForgeState { - -- | The online KES key used to sign blocks - tpraosHotKey :: !(HotKey c) - } - deriving (Generic) - -deriving instance TPraosCrypto c => Show (TPraosForgeState c) - --- We override 'showTypeOf' to make sure to show @c@ -instance TPraosCrypto c => NoUnexpectedThunks (TPraosForgeState c) where - showTypeOf _ = show $ typeRep (Proxy @(TPraosForgeState c)) - --- | Get the KES key from the node state, evolve if its KES period doesn't --- match the given one. -evolveKESKeyIfNecessary - :: forall m c. (MonadRandom m, TPraosCrypto c) - => Update m (TPraosForgeState c) - -> SL.KESPeriod -- ^ Relative KES period (to the start period of the OCert) - -> m () -evolveKESKeyIfNecessary updateForgeState (SL.KESPeriod kesPeriod) = do - runUpdate_ updateForgeState $ \(TPraosForgeState hk@(HotKey kesPeriodOfKey _)) -> - if kesPeriodOfKey >= kesPeriod then - -- No need to evolve - return $ TPraosForgeState hk - else do - let hk' = evolveKey hk - -- Any stateful code (for instance, running finalizers to clear the - -- memory associated with the old key) would happen here - return $ TPraosForgeState hk' - where - -- | Evolve the given key so that its KES period matches @kesPeriod@. - evolveKey :: HotKey c -> HotKey c - evolveKey (HotKey oldPeriod outdatedKey) = go outdatedKey oldPeriod kesPeriod - where - go !sk c t - | t < c - = error "Asked to evolve KES key to old period" - | c == t - = HotKey kesPeriod sk - | otherwise - = case KES.updateKES () sk c of - Nothing -> error "Could not update KES key" - Just sk' -> go sk' (c + 1) t - {------------------------------------------------------------------------------- Forging -------------------------------------------------------------------------------} forgeShelleyBlock - :: (MonadRandom m, TPraosCrypto c) + :: TPraosCrypto c => TopLevelConfig (ShelleyBlock c) -> ForgeState (ShelleyBlock c) -> BlockNo -- ^ Current block number -> TickedLedgerState (ShelleyBlock c) -- ^ Current ledger -> [GenTx (ShelleyBlock c)] -- ^ Txs to add in the block -> TPraosProof c -- ^ Leader proof ('IsLeader') - -> m (ShelleyBlock c) -forgeShelleyBlock cfg forgeState curNo tickedLedger txs isLeader = do - return $ assert (verifyBlockIntegrity tpraosSlotsPerKESPeriod blk) blk - + -> ShelleyBlock c +forgeShelleyBlock cfg forgeState curNo tickedLedger txs isLeader = + assert (verifyBlockIntegrity tpraosSlotsPerKESPeriod blk) blk where TPraosConfig { tpraosParams = TPraosParams { tpraosSlotsPerKESPeriod } } = configConsensus cfg curSlot = tickedSlotNo tickedLedger - tpraosFields = forgeTPraosFields hotKESKey isLeader mkBhBody + hotKey = chainIndepState forgeState + tpraosFields = forgeTPraosFields hotKey isLeader mkBhBody blk = mkShelleyBlock $ SL.Block (mkHeader tpraosFields) body - hotKESKey = tpraosHotKey forgeState body = SL.TxSeq $ Seq.fromList $ (\(ShelleyTx _ tx) -> tx) <$> txs mkHeader TPraosFields { tpraosSignature, tpraosToSign } = diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 80813c50a2d..93cc9fd0deb 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -191,7 +191,7 @@ instance TPraosCrypto c -- + 'applyChainTick': executes the @TICK@ transition -- + 'validateHeader': -- - 'validateEnvelope': executes the @chainChecks@ - -- - 'updateConsensusState': executes the @PRTCL@ transition + -- - 'updateChainDepState': executes the @PRTCL@ transition -- + 'applyLedgerBlock': executes the @BBODY@ transition -- applyLedgerBlock cfg diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs index 5d3417b6d65..6b656402dc5 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs @@ -22,13 +22,13 @@ module Ouroboros.Consensus.Shelley.Node ( ) where import Control.Monad.Reader (runReader) -import Crypto.Random (MonadRandom) import Data.Functor.Identity (Identity) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Cardano.Prelude (Natural) +import Cardano.Crypto.KES.Class import Cardano.Slotting.EpochInfo import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..), WithOrigin (Origin)) @@ -45,6 +45,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) +import Ouroboros.Consensus.Util.IOLike import qualified Shelley.Spec.Ledger.Address as SL import qualified Shelley.Spec.Ledger.BaseTypes as SL @@ -66,7 +67,9 @@ import qualified Ouroboros.Consensus.Shelley.Ledger.History as History import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () import Ouroboros.Consensus.Shelley.Node.Serialisation () import Ouroboros.Consensus.Shelley.Protocol -import Ouroboros.Consensus.Shelley.Protocol.Crypto (HotKey) +import Ouroboros.Consensus.Shelley.Protocol.Crypto +import Ouroboros.Consensus.Shelley.Protocol.Crypto.HotKey + (HotKey (..)) import qualified Ouroboros.Consensus.Shelley.Protocol.State as State {------------------------------------------------------------------------------- @@ -74,36 +77,35 @@ import qualified Ouroboros.Consensus.Shelley.Protocol.State as State -------------------------------------------------------------------------------} data TPraosLeaderCredentials c = TPraosLeaderCredentials { - -- | Signing KES key. Note that this is not inside 'TPraosIsCoreNode' since - -- it gets evolved automatically, whereas 'TPraosIsCoreNode' does not - -- change. - tpraosLeaderCredentialsSignKey :: HotKey c + -- | The unevolved signing KES key (at evolution 0). + -- + -- Note that this is not inside 'TPraosIsCoreNode' since it gets evolved + -- automatically, whereas 'TPraosIsCoreNode' does not change. + tpraosLeaderCredentialsSignKey :: SignKeyKES (KES c) , tpraosLeaderCredentialsIsCoreNode :: TPraosIsCoreNode c } shelleyMaintainForgeState - :: forall m c. (MonadRandom m, TPraosCrypto c) + :: forall m c. (IOLike m, TPraosCrypto c) => TPraosParams -> TPraosLeaderCredentials c -> MaintainForgeState m (ShelleyBlock c) -shelleyMaintainForgeState TPraosParams{..} (TPraosLeaderCredentials key isACoreNode) = - MaintainForgeState { - initForgeState = TPraosForgeState key - , updateForgeState = evolveKey isACoreNode - } +shelleyMaintainForgeState TPraosParams{..} (TPraosLeaderCredentials signKeyKES icn) = + defaultMaintainNoExtraForgeState initHotKey where - evolveKey :: TPraosIsCoreNode c - -> Update m (TPraosForgeState c) -> SlotNo -> m () - evolveKey TPraosIsCoreNode{..} upd curSlot = - evolveKESKeyIfNecessary upd (SL.KESPeriod kesEvolution) - where - kesPeriodNat = fromIntegral $ unSlotNo curSlot `div` tpraosSlotsPerKESPeriod - SL.OCert _ _ (SL.KESPeriod c0) _ = tpraosIsCoreNodeOpCert - kesEvolution = if kesPeriodNat >= c0 then kesPeriodNat - c0 else 0 + SL.KESPeriod start = SL.ocertKESPeriod $ tpraosIsCoreNodeOpCert icn + + initHotKey = HotKey { + hkStart = SL.KESPeriod start + , hkEnd = SL.KESPeriod (start + fromIntegral tpraosMaxKESEvo) + -- We get an unevolved KES key + , hkEvolution = 0 + , hkKey = signKeyKES + } protocolInfoShelley - :: forall m c. (MonadRandom m, TPraosCrypto c) + :: forall m c. (IOLike m, TPraosCrypto c) => SL.ShelleyGenesis c -> Natural -- ^ Max major protocol version -> SL.ProtVer @@ -119,6 +121,7 @@ protocolInfoShelley genesis maxMajorPV protVer mbCredentials = topLevelConfig :: TopLevelConfig (ShelleyBlock c) topLevelConfig = TopLevelConfig { configConsensus = consensusConfig + , configIndep = tpraosParams , configLedger = ledgerConfig , configBlock = blockConfig } @@ -157,8 +160,8 @@ protocolInfoShelley genesis maxMajorPV protVer mbCredentials = , shelleyState = SL.chainNes initShelleyState } - initConsensusState :: State.TPraosState c - initConsensusState = State.empty Origin $ + initChainDepState :: State.TPraosState c + initChainDepState = State.empty Origin $ SL.PrtclState (SL.chainOCertIssue initShelleyState) (SL.chainEpochNonce initShelleyState) @@ -188,7 +191,7 @@ protocolInfoShelley genesis maxMajorPV protVer mbCredentials = initExtLedgerState :: ExtLedgerState (ShelleyBlock c) initExtLedgerState = ExtLedgerState { ledgerState = initLedgerState - , headerState = genesisHeaderState initConsensusState + , headerState = genesisHeaderState initChainDepState } runShelleyBase :: SL.ShelleyBase a -> a diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs index 90f1c733ed8..0ab00674743 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -48,10 +48,10 @@ instance Crypto c => EncodeDisk (ShelleyBlock c) (LedgerState (ShelleyBlock c)) instance Crypto c => DecodeDisk (ShelleyBlock c) (LedgerState (ShelleyBlock c)) where decodeDisk _ = decodeShelleyLedgerState --- | @'ConsensusState' ('BlockProtocol' ('ShelleyBlock' c))@ +-- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' c))@ instance Crypto c => EncodeDisk (ShelleyBlock c) (TPraosState c) where encodeDisk _ = toCBOR --- | @'ConsensusState' ('BlockProtocol' ('ShelleyBlock' c))@ +-- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' c))@ instance Crypto c => DecodeDisk (ShelleyBlock c) (TPraosState c) where decodeDisk _ = fromCBOR diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs index 6d80072a773..3c8a01cefec 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs @@ -25,6 +25,7 @@ module Ouroboros.Consensus.Shelley.Protocol ( , TPraosProof (..) , TPraosIsCoreNode (..) , mkShelleyGlobals + , TPraosUnusableKey(..) , TPraosCannotLead(..) -- * Crypto , Crypto @@ -42,6 +43,7 @@ import Control.Monad.Trans.Except (except) import Data.Coerce (coerce) import Data.Functor.Identity (Identity) import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) import Data.Word (Word64) import GHC.Generics (Generic) @@ -74,6 +76,9 @@ import qualified Shelley.Spec.Ledger.OCert as SL import qualified Shelley.Spec.Ledger.STS.Prtcl as STS import Ouroboros.Consensus.Shelley.Protocol.Crypto +import Ouroboros.Consensus.Shelley.Protocol.Crypto.HotKey + (HotKey (..)) +import qualified Ouroboros.Consensus.Shelley.Protocol.Crypto.HotKey as HotKey import Ouroboros.Consensus.Shelley.Protocol.State (TPraosState) import qualified Ouroboros.Consensus.Shelley.Protocol.State as State import Ouroboros.Consensus.Shelley.Protocol.Util @@ -128,7 +133,7 @@ forgeTPraosFields :: ( TPraosCrypto c -> IsLeader (TPraos c) -> (TPraosToSign c -> toSign) -> TPraosFields c toSign -forgeTPraosFields (HotKey kesEvolution hotKESKey) TPraosProof{..} mkToSign = +forgeTPraosFields HotKey { hkEvolution, hkKey } TPraosProof{..} mkToSign = TPraosFields { tpraosSignature = signature , tpraosToSign = mkToSign signedFields @@ -136,9 +141,9 @@ forgeTPraosFields (HotKey kesEvolution hotKESKey) TPraosProof{..} mkToSign = where signature = signedKES () - kesEvolution + hkEvolution (mkToSign signedFields) - hotKESKey + hkKey TPraosIsCoreNode{..} = tpraosIsCoreNode @@ -211,7 +216,7 @@ data TPraosIsCoreNode c = TPraosIsCoreNode { -- | Certificate delegating rights from the stake pool cold key (or -- genesis stakeholder delegate cold key) to the online KES key. tpraosIsCoreNodeOpCert :: !(SL.OCert c) - -- | Stake pool cold key or genesis stakeholder delegate cold key. + -- | Stake pool cold key or genesis stakeholder delegate cold key. , tpraosIsCoreNodeColdVerKey :: !(SL.VKey 'SL.BlockIssuer c) , tpraosIsCoreNodeSignKeyVRF :: !(SignKeyVRF (VRF c)) } @@ -230,21 +235,44 @@ data TPraosProof c = TPraosProof { instance TPraosCrypto c => NoUnexpectedThunks (TPraosProof c) +data TPraosUnusableKey = TPraosUnusableKey { + tpraosUnusableKeyStart :: !SL.KESPeriod + , tpraosUnusableKeyEnd :: !SL.KESPeriod + , tpraosUnusableKeyCurrent :: !SL.KESPeriod + -- ^ Current KES period of the key + , tpraosUnusableWallClock :: !SL.KESPeriod + -- ^ Current KES period according to the wallclock slot, i.e., the KES + -- period in which we want to use the key. + } + deriving (Show) + +checkKesPeriod :: SL.KESPeriod -> HotKey c -> Either TPraosUnusableKey () +checkKesPeriod wallclockPeriod hk + | let curKeyPeriod = HotKey.toPeriod hk + , curKeyPeriod /= wallclockPeriod + = Left TPraosUnusableKey { + tpraosUnusableKeyStart = hkStart hk + , tpraosUnusableKeyEnd = hkEnd hk + , tpraosUnusableKeyCurrent = curKeyPeriod + , tpraosUnusableWallClock = wallclockPeriod + } + | otherwise + = Right () + -- | Expresses that, whilst we believe ourselves to be a leader for this slot, -- we are nonetheless unable to forge a block. data TPraosCannotLead c = - -- | Our operational certificate is not valid for the current KES period. The - -- given parameters are the current KES period, the minimum and maximum KES - -- periods for which this operational certificate is valid. - TPraosCannotLeadInvalidOcert KES.Period KES.Period KES.Period + -- | The KES key in our operational certificate is not usable for the + -- current KES period. + TPraosCannotLeadUnusableKESKey !TPraosUnusableKey -- | We are a genesis delegate, but our VRF key does not match the -- registered key for that delegate. | TPraosCannotLeadWrongVRF - (SL.Hash c (VerKeyVRF (VRF c))) - (SL.Hash c (VerKeyVRF (VRF c))) + !(SL.Hash c (VerKeyVRF (VRF c))) + !(SL.Hash c (VerKeyVRF (VRF c))) deriving (Generic) -deriving instance (TPraosCrypto c) => Show (TPraosCannotLead c) +deriving instance TPraosCrypto c => Show (TPraosCannotLead c) -- | Static configuration data instance ConsensusConfig (TPraos c) = TPraosConfig { @@ -283,25 +311,37 @@ instance TPraosCrypto c => ChainSelection (TPraos c) where -- operational certificate issue number. type SelectView (TPraos c) = TPraosChainSelectView c +instance TPraosCrypto c => HasChainIndepState (TPraos c) where + type ChainIndepStateConfig (TPraos c) = TPraosParams + type ChainIndepState (TPraos c) = HotKey c + + updateChainIndepState _proxy TPraosParams{..} curSlot hk = + -- When the period is outside the range of the key, we can't evolve it + -- and get a 'Nothing'. We don't throw an error or exception here, we + -- will return/trace this as 'CannotLead'. + fromMaybe hk <$> HotKey.evolve curPeriod hk + where + curPeriod = SL.KESPeriod $ fromIntegral $ unSlotNo curSlot `div` tpraosSlotsPerKESPeriod + instance TPraosCrypto c => ConsensusProtocol (TPraos c) where - type ConsensusState (TPraos c) = TPraosState c - type IsLeader (TPraos c) = TPraosProof c - type CanBeLeader (TPraos c) = TPraosIsCoreNode c - type CannotLead (TPraos c) = TPraosCannotLead c - type LedgerView (TPraos c) = SL.LedgerView c - type ValidationErr (TPraos c) = [[STS.PredicateFailure (STS.PRTCL c)]] - type ValidateView (TPraos c) = TPraosValidateView c + type ChainDepState (TPraos c) = TPraosState c + type IsLeader (TPraos c) = TPraosProof c + type CanBeLeader (TPraos c) = TPraosIsCoreNode c + type CannotLead (TPraos c) = TPraosCannotLead c + type LedgerView (TPraos c) = SL.LedgerView c + type ValidationErr (TPraos c) = [[STS.PredicateFailure (STS.PRTCL c)]] + type ValidateView (TPraos c) = TPraosValidateView c protocolSecurityParam = tpraosSecurityParam . tpraosParams - checkIsLeader cfg@TPraosConfig{..} icn (Ticked slot lv) cs = do + checkIsLeader cfg@TPraosConfig{..} icn (Ticked slot lv) hk cs = do rho <- VRF.evalCertified () rho' tpraosIsCoreNodeSignKeyVRF y <- VRF.evalCertified () y' tpraosIsCoreNodeSignKeyVRF -- First, check whether we're in the overlay schedule return $ case Map.lookup slot (SL.lvOverlaySched lv) of Nothing | meetsLeaderThreshold cfg lv (SL.coerceKeyRole vkhCold) y - -> case hasValidOCert icn of + -> case checkKesPeriod wallclockPeriod hk of Right () -> -- Slot isn't in the overlay schedule, so we're in Praos IsLeader TPraosProof { @@ -309,8 +349,8 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where , tpraosLeader = coerce y , tpraosIsCoreNode = icn } - Left (c, mi, ma) -> - CannotLead $ TPraosCannotLeadInvalidOcert c mi ma + Left unusableKey -> + CannotLead $ TPraosCannotLeadUnusableKESKey unusableKey | otherwise -> NotLeader @@ -320,25 +360,24 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where -- The given genesis key has authority to produce a block in this -- slot. Check whether we're its delegate. Just (SL.ActiveSlot gkhash) -> case Map.lookup gkhash dlgMap of + Nothing + -> error "unknown genesis key in overlay schedule" Just (SL.GenDelegPair dlgHash genDlgVRFHash) - | SL.coerceKeyRole dlgHash == vkhCold - -> case hasValidOCert icn of - Right () -> - if genDlgVRFHash == coreNodeVRFHash - then - IsLeader TPraosProof { - tpraosEta = coerce rho - -- Note that this leader value is not checked for slots in - -- the overlay schedule, so we could set it to whatever we - -- want. We evaluate it as normal for simplicity's sake. - , tpraosLeader = coerce y - , tpraosIsCoreNode = icn - } - else - CannotLead $ TPraosCannotLeadWrongVRF genDlgVRFHash coreNodeVRFHash - Left (c, mi, ma) -> - CannotLead $ TPraosCannotLeadInvalidOcert c mi ma - _ -> NotLeader + | SL.coerceKeyRole dlgHash /= vkhCold + -> NotLeader + | Left unusableKey <- checkKesPeriod wallclockPeriod hk + -> CannotLead $ TPraosCannotLeadUnusableKESKey unusableKey + | genDlgVRFHash /= coreNodeVRFHash + -> CannotLead $ TPraosCannotLeadWrongVRF genDlgVRFHash coreNodeVRFHash + | otherwise + -> IsLeader TPraosProof { + tpraosEta = coerce rho + -- Note that this leader value is not checked for slots in + -- the overlay schedule, so we could set it to whatever we + -- want. We evaluate it as normal for simplicity's sake. + , tpraosLeader = coerce y + , tpraosIsCoreNode = icn + } where SL.GenDelegs dlgMap = SL.lvGenDelegs lv coreNodeVRFHash = SL.hashVerKeyVRF $ deriveVerKeyVRF tpraosIsCoreNodeSignKeyVRF @@ -354,26 +393,12 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where rho' = SL.mkSeed SL.seedEta slot eta0 y' = SL.mkSeed SL.seedL slot eta0 - -- | Check whether we have an operational certificate valid for the - -- current KES period. - -- - -- Returns 'Right ()' when the OCert is valid and 'Left (current, min, - -- max)' when it is not. - hasValidOCert - :: TPraosIsCoreNode c - -> Either (KES.Period, KES.Period, KES.Period) () - hasValidOCert TPraosIsCoreNode{tpraosIsCoreNodeOpCert} = - if kesPeriod >= c0 && kesPeriod < c1 - then Right () - else Left (kesPeriod, c0, c1) - where - SL.OCert _ _ (SL.KESPeriod c0) _ = tpraosIsCoreNodeOpCert - c1 = c0 + fromIntegral (tpraosMaxKESEvo tpraosParams) - -- The current KES period - kesPeriod = fromIntegral $ - unSlotNo slot `div` tpraosSlotsPerKESPeriod tpraosParams - - updateConsensusState TPraosConfig{..} (Ticked _ lv) b cs = do + -- The current wallclock KES period + wallclockPeriod :: SL.KESPeriod + wallclockPeriod = SL.KESPeriod $ fromIntegral $ + unSlotNo slot `div` tpraosSlotsPerKESPeriod tpraosParams + + updateChainDepState TPraosConfig{..} (Ticked _ lv) b cs = do newCS <- except . flip runReader shelleyGlobals $ applySTS @(STS.PRTCL c) $ STS.TRC (prtclEnv, prtclState, b) return @@ -398,7 +423,7 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where -- -- 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. - rewindConsensusState _proxy _k = State.rewind . pointSlot + rewindChainDepState _proxy _k = State.rewind . pointSlot mkShelleyGlobals :: EpochInfo Identity -> TPraosParams -> SL.Globals mkShelleyGlobals epochInfo TPraosParams {..} = SL.Globals { diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto.hs index fffccf82bed..06bd70a2276 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto.hs @@ -1,20 +1,15 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.Shelley.Protocol.Crypto ( module Shelley.Spec.Ledger.Crypto - , HotKey(..) , TPraosCrypto , TPraosStandardCrypto ) where import Data.Typeable (Typeable) -import GHC.Generics (Generic) import Numeric.Natural import Cardano.Binary (ToCBOR) @@ -22,12 +17,10 @@ import qualified Cardano.Crypto.DSIGN.Class as DSIGN import Cardano.Crypto.DSIGN.Ed25519 (Ed25519DSIGN) import Cardano.Crypto.Hash.Blake2b (Blake2b_224, Blake2b_256) import Cardano.Crypto.Hash.Class (Hash) -import Cardano.Crypto.KES.Class import qualified Cardano.Crypto.KES.Class as KES import Cardano.Crypto.KES.Sum import qualified Cardano.Crypto.VRF.Class as VRF import Cardano.Crypto.VRF.Simple (SimpleVRF) -import Cardano.Prelude (NoUnexpectedThunks (..)) import Ouroboros.Consensus.Util.Condense (Condense) @@ -63,13 +56,3 @@ instance Crypto TPraosStandardCrypto where type ADDRHASH TPraosStandardCrypto = Blake2b_224 instance TPraosCrypto TPraosStandardCrypto - --- | A hot KES key. We store alongside the key the KES period for which it is --- valid. -data HotKey c = HotKey !Period !(SignKeyKES (KES c)) - deriving Generic - -instance Show (HotKey c) where - show _ = "" - -instance TPraosCrypto c => NoUnexpectedThunks (HotKey c) diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto/HotKey.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto/HotKey.hs new file mode 100644 index 00000000000..8be32d4c756 --- /dev/null +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto/HotKey.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Hot key +-- +-- Intended for qualified import +module Ouroboros.Consensus.Shelley.Protocol.Crypto.HotKey ( + KESEvolution + , HotKey (..) + , toPeriod + , evolve + ) where + +import GHC.Generics (Generic) + +import Cardano.Crypto.KES.Class +import qualified Cardano.Crypto.KES.Class as Relative (Period) +import Cardano.Prelude (NoUnexpectedThunks (..)) + +import Shelley.Spec.Ledger.Crypto (Crypto (..)) +import qualified Shelley.Spec.Ledger.OCert as Absolute (KESPeriod (..)) + +import Ouroboros.Consensus.Util.IOLike + + +-- | We call the relative periods that a KES key is valid its evolution, to +-- avoid confusion with absolute periods. +type KESEvolution = Relative.Period + +-- | A hot KES key +data HotKey c = HotKey { + hkStart :: !Absolute.KESPeriod + , hkEnd :: !Absolute.KESPeriod + -- ^ Currently derived from `TPraosParams`: + -- > hkEnd = hkStart + tpraosMaxKESEvo + , hkEvolution :: !KESEvolution + -- ^ Invariant: + -- > hkStart + hkEvolution in [hkStart, hkEnd] + , hkKey :: !(SignKeyKES (KES c)) + } + deriving (Generic) + +instance Show (HotKey c) where + show HotKey { hkStart, hkEnd, hkEvolution } = mconcat [ + "" + ] + +instance Crypto c => NoUnexpectedThunks (HotKey c) + +-- | Return the evolution of the given KES period, /when/ it falls within the +-- range of the 'HotKey' (@[hkStart, hkEnd]@). +toEvolution :: HotKey c -> Absolute.KESPeriod -> Maybe KESEvolution +toEvolution HotKey { hkStart = Absolute.KESPeriod lo + , hkEnd = Absolute.KESPeriod hi + } + (Absolute.KESPeriod cur) + | lo <= cur, cur <= hi = Just (cur - lo) + | otherwise = Nothing + +-- | Return the current period of the 'HotKey'. +toPeriod :: HotKey c -> Absolute.KESPeriod +toPeriod HotKey { hkStart = Absolute.KESPeriod lo, hkEvolution } = + Absolute.KESPeriod (lo + hkEvolution) + +-- | Evolve the 'HotKey' so that its evolution matches the given KES period. +-- +-- When the 'HotKey' has already evolved further than the given KES period, we +-- return 'Nothing'. +-- +-- When the given KES period is outside the bounds of the 'HotKey', we return +-- 'Nothing'. +evolve :: + forall c m. (IOLike m, Crypto c) + => Absolute.KESPeriod + -> HotKey c + -> m (Maybe (HotKey c)) +evolve targetPeriod hk = do + let mNewHotKey = do + targetEvolution <- toEvolution hk targetPeriod + key' <- go targetEvolution (hkEvolution hk) (hkKey hk) + return HotKey { + hkStart = hkStart hk + , hkEnd = hkEnd hk + , hkEvolution = targetEvolution + , hkKey = key' + } + -- Any stateful code (for instance, running finalizers to clear the + -- memory associated with the old key) would happen here or in (a + -- monadic) 'go'. + return mNewHotKey + where + go :: KESEvolution + -> KESEvolution + -> SignKeyKES (KES c) + -> Maybe (SignKeyKES (KES c)) + go targetEvolution curEvolution key + | targetEvolution == curEvolution + = Just key + | targetEvolution < curEvolution + = Nothing + | otherwise + = case updateKES () key curEvolution of + -- This cannot happen + Nothing -> error "Could not update KES key" + Just key' -> go targetEvolution (curEvolution + 1) key' diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs index 66c7ce4e080..cdb24989783 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs @@ -136,9 +136,8 @@ instance ( SimpleCrypto c , Signable (BftDSIGN c') (SignedSimpleBft c c') ) => CanForge (SimpleBftBlock c c') where - type ForgeState (SimpleBftBlock c c') = () forgeBlock = forgeSimple $ ForgeExt $ \cfg _update _isLeader -> - return . forgeBftExt cfg + forgeBftExt cfg {------------------------------------------------------------------------------- Serialisation diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs index 4dfb6c417e0..d269974067e 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs @@ -153,9 +153,8 @@ instance ( SimpleCrypto c , ContextDSIGN (PBftDSIGN c') ~ () ) => CanForge (SimplePBftBlock c c') where - type ForgeState (SimplePBftBlock c c') = () forgeBlock = forgeSimple $ ForgeExt $ \_cfg _update isLeader -> - return . forgePBftExt isLeader + forgePBftExt isLeader {------------------------------------------------------------------------------- Serialisation diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs index 82c5355d19d..3bf25ca8d77 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs @@ -23,7 +23,6 @@ import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (encodeListLen) import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (Serialise (..)) -import Crypto.Random (MonadRandom) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -155,40 +154,40 @@ stakeDist = equalStakeDist . simpleMockLedgerConfig Forging -------------------------------------------------------------------------------} -forgePraosExt :: forall c c' m. +forgePraosExt :: forall c c'. ( SimpleCrypto c , PraosCrypto c' , Signable (PraosKES c') (SignedSimplePraos c c') - , MonadRandom m ) => TopLevelConfig (SimplePraosBlock c c') - -> PraosForgeState c' + -> ForgeState (SimplePraosBlock c c') -> IsLeader (BlockProtocol (SimplePraosBlock c c')) -> SimpleBlock' c (SimplePraosExt c c') () - -> m (SimplePraosBlock c c') -forgePraosExt cfg forgeState isLeader SimpleBlock{..} = do - ext :: SimplePraosExt c c' <- fmap SimplePraosExt $ + -> SimplePraosBlock c c' +forgePraosExt cfg ForgeState { chainIndepState = hotKey } isLeader SimpleBlock{..} = + SimpleBlock { + simpleHeader = mkSimpleHeader encode simpleHeaderStd ext + , simpleBody = simpleBody + } + where + SimpleHeader{..} = simpleHeader + + ext :: SimplePraosExt c c' + ext = SimplePraosExt $ forgePraosFields (configConsensus cfg) - forgeState + hotKey isLeader $ \praosExtraFields -> SignedSimplePraos { signedSimplePraos = simpleHeaderStd , signedPraosFields = praosExtraFields } - return SimpleBlock { - simpleHeader = mkSimpleHeader encode simpleHeaderStd ext - , simpleBody = simpleBody - } - where - SimpleHeader{..} = simpleHeader instance ( SimpleCrypto c , PraosCrypto c' , Signable (PraosKES c') (SignedSimplePraos c c') ) => CanForge (SimplePraosBlock c c') where - type ForgeState (SimplePraosBlock c c') = PraosForgeState c' forgeBlock = forgeSimple $ ForgeExt forgePraosExt {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs index df748c5d6d1..a5cea809866 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs @@ -128,9 +128,8 @@ forgePraosRuleExt cfg SimpleBlock{..} = SimpleHeader{..} = simpleHeader instance SimpleCrypto c => CanForge (SimplePraosRuleBlock c) where - type ForgeState (SimplePraosRuleBlock c) = () forgeBlock = forgeSimple $ ForgeExt $ \cfg _update _isLeader -> - return . forgePraosRuleExt cfg + forgePraosRuleExt cfg {------------------------------------------------------------------------------- Serialisation diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Forge.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Forge.hs index 518b84c0d47..bc545e72a37 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Forge.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Forge.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -12,7 +11,6 @@ module Ouroboros.Consensus.Mock.Ledger.Forge ( ) where import Codec.Serialise (Serialise (..), serialise) -import Crypto.Random (MonadRandom) import qualified Data.ByteString.Lazy as Lazy import Data.Word @@ -31,17 +29,15 @@ import Ouroboros.Consensus.Protocol.Abstract -- This is used in 'forgeSimple', which takes care of the generic part of the -- mock block. data ForgeExt c ext = ForgeExt { - forgeExt :: forall m. MonadRandom m - => TopLevelConfig (SimpleBlock c ext) + forgeExt :: TopLevelConfig (SimpleBlock c ext) -> ForgeState (SimpleBlock c ext) -> IsLeader (BlockProtocol (SimpleBlock c ext)) -> SimpleBlock' c ext () - -> m (SimpleBlock c ext) + -> SimpleBlock c ext } -forgeSimple :: forall c m ext. - ( MonadRandom m - , SimpleCrypto c +forgeSimple :: forall c ext. + ( SimpleCrypto c , MockProtocolSpecific c ext ) => ForgeExt c ext @@ -51,8 +47,8 @@ forgeSimple :: forall c m ext. -> TickedLedgerState (SimpleBlock c ext) -- ^ Current ledger -> [GenTx (SimpleBlock c ext)] -- ^ Txs to include -> IsLeader (BlockProtocol (SimpleBlock c ext)) - -> m (SimpleBlock c ext) -forgeSimple ForgeExt { forgeExt } cfg forgeState curBlock tickedLedger txs proof = do + -> SimpleBlock c ext +forgeSimple ForgeExt { forgeExt } cfg forgeState curBlock tickedLedger txs proof = forgeExt cfg forgeState proof $ SimpleBlock { simpleHeader = mkSimpleHeader encode stdHeader () , simpleBody = body diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Abstract.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Abstract.hs index 4d8b0722a85..9fb77f916c0 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Abstract.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Abstract.hs @@ -28,8 +28,8 @@ import Ouroboros.Consensus.Storage.ChainDB.Serialisation -- | Protocol specific functionality required to run consensus with mock blocks class ( MockProtocolSpecific c ext - , EncodeDisk (SimpleBlock c ext) (ConsensusState (BlockProtocol (SimpleBlock c ext))) - , DecodeDisk (SimpleBlock c ext) (ConsensusState (BlockProtocol (SimpleBlock c ext))) + , EncodeDisk (SimpleBlock c ext) (ChainDepState (BlockProtocol (SimpleBlock c ext))) + , DecodeDisk (SimpleBlock c ext) (ChainDepState (BlockProtocol (SimpleBlock c ext))) ) => RunMockBlock c ext where mockProtocolMagicId :: BlockConfig (SimpleBlock c ext) diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/BFT.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/BFT.hs index da0702fdf27..74409669703 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/BFT.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/BFT.hs @@ -40,6 +40,7 @@ protocolInfoBft numCoreNodes nid securityParam eraParams = | n <- enumCoreNodes numCoreNodes ] } + , configIndep = () , configLedger = SimpleLedgerConfig () eraParams , configBlock = SimpleBlockConfig securityParam } diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/PBFT.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/PBFT.hs index c3a6df7de37..7433d0d7ecf 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/PBFT.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/PBFT.hs @@ -34,6 +34,7 @@ protocolInfoMockPBFT params eraParams nid = configConsensus = PBftConfig { pbftParams = params } + , configIndep = () , configLedger = SimpleLedgerConfig ledgerView eraParams , configBlock = SimpleBlockConfig (pbftSecurityParam params) } diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Praos.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Praos.hs index 7729dd0baea..e2feb706d44 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Praos.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Praos.hs @@ -23,10 +23,11 @@ import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Mock.Protocol.Praos import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId (CoreNodeId (..)) +import Ouroboros.Consensus.Util.IOLike type MockPraosBlock = SimplePraosBlock SimpleMockCrypto PraosMockCrypto -protocolInfoPraos :: Monad m +protocolInfoPraos :: IOLike m => NumCoreNodes -> CoreNodeId -> PraosParams @@ -42,6 +43,7 @@ protocolInfoPraos numCoreNodes nid params eraParams = , praosInitialStake = genesisStakeDist addrDist , praosVerKeys = verKeys } + , configIndep = () , configLedger = SimpleLedgerConfig addrDist eraParams , configBlock = SimpleBlockConfig (praosSecurityParam params) } @@ -51,14 +53,13 @@ protocolInfoPraos numCoreNodes nid params eraParams = } , pInfoLeaderCreds = Just ( nid - , MaintainForgeState { - initForgeState = - PraosKey $ + , defaultMaintainNoExtraForgeState + (HotKey $ SignKeyMockKES - (fst $ verKeys Map.! nid) -- key ID - 0 -- KES initial slot - , updateForgeState = evolveKey - } + -- key ID + (fst $ verKeys Map.! nid) + -- KES initial slot + 0) ) } where diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/PraosRule.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/PraosRule.hs index 80bc470c864..02dd0a34888 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/PraosRule.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/PraosRule.hs @@ -20,10 +20,11 @@ import Ouroboros.Consensus.Mock.Protocol.Praos import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId (CoreNodeId (..)) import Ouroboros.Consensus.Protocol.LeaderSchedule +import Ouroboros.Consensus.Util.IOLike type MockPraosRuleBlock = SimplePraosRuleBlock SimpleMockCrypto -protocolInfoPraosRule :: Monad m +protocolInfoPraosRule :: IOLike m => NumCoreNodes -> CoreNodeId -> PraosParams @@ -48,6 +49,7 @@ protocolInfoPraosRule numCoreNodes } , wlsConfigNodeId = nid } + , configIndep = () , configLedger = SimpleLedgerConfig () eraParams , configBlock = SimpleBlockConfig (praosSecurityParam params) } diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Protocol/Praos.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Protocol/Praos.hs index 7d8c8628c21..d1166f51f2b 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Protocol/Praos.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Protocol/Praos.hs @@ -22,7 +22,7 @@ module Ouroboros.Consensus.Mock.Protocol.Praos ( , PraosFields(..) , PraosExtraFields(..) , PraosParams(..) - , PraosForgeState(..) + , HotKey(..) , forgePraosFields , evolveKey -- * Tags @@ -69,7 +69,6 @@ import Ouroboros.Network.Block (HasHeader (..), SlotNo (..), pointSlot) import Ouroboros.Network.Point (WithOrigin (At)) -import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Mock.Ledger.Stake import Ouroboros.Consensus.NodeId (CoreNodeId (..)) @@ -120,38 +119,35 @@ praosValidateView getFields hdr = Forging -------------------------------------------------------------------------------} -data PraosForgeState c = - -- | The KES key - PraosKey !(SignKeyKES (PraosKES c)) +newtype HotKey c = HotKey (SignKeyKES (PraosKES c)) deriving (Generic) -deriving instance PraosCrypto c => Show (PraosForgeState c) +deriving instance PraosCrypto c => Show (HotKey c) -- We override 'showTypeOf' to make sure to show @c@ -instance PraosCrypto c => NoUnexpectedThunks (PraosForgeState c) where - showTypeOf _ = show $ typeRep (Proxy @(PraosForgeState c)) +instance PraosCrypto c => NoUnexpectedThunks (HotKey c) where + showTypeOf _ = show $ typeRep (Proxy @(HotKey c)) evolveKey :: (Monad m, PraosCrypto c) - => Update m (PraosForgeState c) -> SlotNo -> m () -evolveKey upd slotNo = runUpdate_ upd $ \(PraosKey oldKey) -> do + => SlotNo -> HotKey c -> m (HotKey c) +evolveKey slotNo (HotKey oldKey) = do let newKey = fromMaybe (error "evolveKey: updateKES failed") $ updateKES () oldKey kesPeriod - return $ PraosKey newKey + return $ HotKey newKey where kesPeriod :: Period kesPeriod = fromIntegral $ unSlotNo slotNo -forgePraosFields :: ( Monad m - , PraosCrypto c +forgePraosFields :: ( PraosCrypto c , Cardano.Crypto.KES.Class.Signable (PraosKES c) toSign ) => ConsensusConfig (Praos c) - -> PraosForgeState c + -> HotKey c -> PraosProof c -> (PraosExtraFields c -> toSign) - -> m (PraosFields c toSign) -forgePraosFields PraosConfig{..} (PraosKey key) PraosProof{..} mkToSign = do - return $ PraosFields { + -> PraosFields c toSign +forgePraosFields PraosConfig{..} (HotKey key) PraosProof{..} mkToSign = + PraosFields { praosSignature = signature , praosExtraFields = signedFields } @@ -250,18 +246,22 @@ data instance ConsensusConfig (Praos c) = PraosConfig instance PraosCrypto c => ChainSelection (Praos c) where -- Use defaults +instance PraosCrypto c => HasChainIndepState (Praos c) where + type ChainIndepState (Praos c) = HotKey c + updateChainIndepState _ () = evolveKey + instance PraosCrypto c => ConsensusProtocol (Praos c) where protocolSecurityParam = praosSecurityParam . praosParams - type LedgerView (Praos c) = StakeDist - type IsLeader (Praos c) = PraosProof c - type ValidationErr (Praos c) = PraosValidationError c - type ValidateView (Praos c) = PraosValidateView c - type ConsensusState (Praos c) = [BlockInfo c] - type CanBeLeader (Praos c) = CoreNodeId - type CannotLead (Praos c) = Void + type LedgerView (Praos c) = StakeDist + type IsLeader (Praos c) = PraosProof c + type ValidationErr (Praos c) = PraosValidationError c + type ValidateView (Praos c) = PraosValidateView c + type ChainDepState (Praos c) = [BlockInfo c] + type CanBeLeader (Praos c) = CoreNodeId + type CannotLead (Praos c) = Void - checkIsLeader cfg@PraosConfig{..} nid (Ticked slot _u) cs = do + checkIsLeader cfg@PraosConfig{..} nid (Ticked slot _u) _cis cds = do rho <- evalCertified () rho' praosSignKeyVRF y <- evalCertified () y' praosSignKeyVRF return $ if fromIntegral (getOutputVRFNatural (certifiedOutput y)) < t @@ -273,12 +273,12 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where } else NotLeader where - (rho', y', t) = rhoYT cfg cs slot nid + (rho', y', t) = rhoYT cfg cds slot nid - updateConsensusState cfg@PraosConfig{..} - (Ticked _ sd) - (PraosValidateView slot PraosFields{..} toSign) - cs = do + updateChainDepState cfg@PraosConfig{..} + (Ticked _ sd) + (PraosValidateView slot PraosFields{..} toSign) + cs = do let PraosExtraFields{..} = praosExtraFields nid = praosCreator @@ -349,7 +349,7 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where -- -- 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. - rewindConsensusState _proxy _k rewindTo = + rewindChainDepState _proxy _k rewindTo = -- This may drop us back to the empty list if we go back to genesis Just . dropWhile (\bi -> At (biSlot bi) > pointSlot rewindTo) diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs index 9e610c03cc2..48303e7e1f7 100644 --- a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs @@ -143,7 +143,7 @@ instance Show (ForgeEbbEnv blk) where -- will restart and use 'tnaRekeyM' to compute its new 'ProtocolInfo'. type RekeyM m blk = CoreNodeId - -> ProtocolInfo (ChaChaT m) blk + -> ProtocolInfo m blk -> SlotNo -- ^ The slot in which the node is rekeying -> (SlotNo -> m EpochNo) @@ -158,11 +158,11 @@ data TestNodeInitialization m blk = TestNodeInitialization { tniCrucialTxs :: [GenTx blk] -- ^ these transactions are added immediately and repeatedly (whenever the -- 'ledgerTipSlot' changes) - , tniProtocolInfo :: ProtocolInfo (ChaChaT m) blk + , tniProtocolInfo :: ProtocolInfo m blk } plainTestNodeInitialization - :: ProtocolInfo (ChaChaT m) blk -> TestNodeInitialization m blk + :: ProtocolInfo m blk -> TestNodeInitialization m blk plainTestNodeInitialization pInfo = TestNodeInitialization { tniCrucialTxs = [] , tniProtocolInfo = pInfo @@ -430,7 +430,7 @@ runThreadNetwork systemTime ThreadNetworkArgs NodeRestarts m = nodeRestarts loop :: SlotNo - -> ProtocolInfo (ChaChaT m) blk + -> ProtocolInfo m blk -> NodeRestart -> Map SlotNo NodeRestart -> m () loop s pInfo nr rs = do @@ -676,7 +676,7 @@ runThreadNetwork systemTime ThreadNetworkArgs -> OracularClock m -> SlotNo -> ResourceRegistry m - -> ProtocolInfo (ChaChaT m) blk + -> ProtocolInfo m blk -> NodeInfo blk (StrictTVar m MockFS) (Tracer m) -> [GenTx blk] -- ^ valid transactions the node should immediately propagate @@ -712,7 +712,7 @@ runThreadNetwork systemTime ThreadNetworkArgs Just creds -> creds blockProduction <- blockProductionIOLike pInfoConfig canBeLeader maintainForgeState varRNG $ - \upd currentBno tickedLdgSt txs prf -> do + \forgeState currentBno tickedLdgSt txs prf -> do let currentSlot = tickedSlotNo tickedLdgSt let currentEpoch = HFF.futureSlotToEpoch future currentSlot @@ -730,8 +730,14 @@ runThreadNetwork systemTime ThreadNetworkArgs case mbForgeEbbEnv <* guard needEBB of Nothing -> -- no EBB needed, forge without making one - forgeBlock pInfoConfig upd - currentBno tickedLdgSt txs prf + return $ + forgeBlock + pInfoConfig + forgeState + currentBno + tickedLdgSt + txs + prf Just forgeEbbEnv -> do -- The EBB shares its BlockNo with its predecessor (if -- there is one) @@ -760,14 +766,19 @@ runThreadNetwork systemTime ThreadNetworkArgs -- forge the block usings the ledger state that includes -- the EBB - blk <- forgeBlock pInfoConfig upd - currentBno tickedLdgSt' txs prf + let blk = forgeBlock + pInfoConfig + forgeState + currentBno + tickedLdgSt' + txs + prf -- If the EBB or the subsequent block is invalid, then the -- ChainDB will reject it as invalid, and -- 'Test.ThreadNet.General.prop_general' will eventually fail -- because of a block rejection. - void $ lift $ ChainDB.addBlock chainDB ebb + void $ ChainDB.addBlock chainDB ebb pure blk let -- prop_general relies on these tracers @@ -1291,7 +1302,7 @@ type TracingConstraints blk = , Show (Header blk) , Show (GenTx blk) , Show (GenTxId blk) - , Show (ForgeState blk) + , Show (ExtraForgeState blk) , ShowQuery (Query blk) , HasNestedContent Header blk ) diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Rekeying.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Rekeying.hs index 2902ba5905c..370689ba2dc 100644 --- a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Rekeying.hs +++ b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Rekeying.hs @@ -15,7 +15,6 @@ import Ouroboros.Consensus.Util.IOLike import Test.ThreadNet.Network -import Test.Util.Random import Test.Util.Stream -- | Functionality used by test node in order to update its operational key @@ -32,7 +31,7 @@ data Rekeying m blk = forall opKey. Rekeying -- IE the first slot that will result in a block successfully being forged -- and diffused (eg no @PBftExceededSignThreshold@). , rekeyUpd :: - ProtocolInfo (ChaChaT m) blk + ProtocolInfo m blk -> EpochNo -> opKey -> Maybe (TestNodeInitialization m blk) diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Util/BlockProduction.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Util/BlockProduction.hs index 284214719b7..49d737ae2b9 100644 --- a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Util/BlockProduction.hs +++ b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Util/BlockProduction.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.ThreadNet.Util.BlockProduction ( blockProductionIOLike @@ -22,40 +23,44 @@ import Test.Util.Random -- -- Unlike 'IO', 'IOLike' does not give us 'MonadRandom', and so we need to -- simulate it. -blockProductionIOLike :: forall m blk. - (IOLike m, BlockSupportsProtocol blk, CanForge blk) - => TopLevelConfig blk - -> CanBeLeader (BlockProtocol blk) - -> MaintainForgeState (ChaChaT m) blk - -> StrictTVar m ChaChaDRG - -> ( ForgeState blk - -> BlockNo - -> TickedLedgerState blk - -> [GenTx blk] - -> IsLeader (BlockProtocol blk) - -> ChaChaT m blk) - -> m (BlockProduction m blk) +blockProductionIOLike :: + forall m blk. + ( IOLike m + , BlockSupportsProtocol blk + , NoUnexpectedThunks (ExtraForgeState blk) + ) + => TopLevelConfig blk + -> CanBeLeader (BlockProtocol blk) + -> MaintainForgeState m blk + -> StrictTVar m ChaChaDRG + -> ( ForgeState blk + -> BlockNo + -> TickedLedgerState blk + -> [GenTx blk] + -> IsLeader (BlockProtocol blk) + -> m blk) + -- ^ We don't use 'forgeBlock' directly but a custom function, used to + -- create EBBs JIT. + -> m (BlockProduction m blk) blockProductionIOLike cfg canBeLeader mfs varRNG forge = do - varForgeState <- newMVar (initForgeState mfs) - let upd :: Update (ChaChaT m) (ForgeState blk) - upd = updateFromMVar (castStrictMVar varForgeState) + varForgeState :: StrictMVar m (ForgeState blk) <- newMVar (initForgeState mfs) return $ BlockProduction { - getLeaderProof = \tracer ledgerState consensusState -> + getLeaderProof = \tracer ledgerState chainDepState -> simMonadRandom varRNG $ defaultGetLeaderProof cfg canBeLeader - mfs - (traceUpdate (natTracer lift tracer) upd) + (hoistMaintainForgeState lift mfs) + (castStrictMVar varForgeState) + (natTracer lift tracer) ledgerState - consensusState + chainDepState , produceBlock = \bno ledgerState txs proof -> do forgeState <- readMVar varForgeState - simMonadRandom varRNG $ - forge - forgeState - bno - ledgerState - txs - proof + forge + forgeState + bno + ledgerState + txs + proof } diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/Serialisation.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/Serialisation.hs index cd2931e01aa..badb5b30f06 100644 --- a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/Serialisation.hs +++ b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/Serialisation.hs @@ -43,7 +43,7 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run (SerialiseNodeToClientConstraints, SerialiseNodeToNodeConstraints) import Ouroboros.Consensus.Node.Serialisation -import Ouroboros.Consensus.Protocol.Abstract (ConsensusState) +import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) import Ouroboros.Consensus.Storage.ChainDB (SerialiseDiskConstraints) import Ouroboros.Consensus.Storage.ChainDB.Serialisation import Ouroboros.Consensus.Util (Dict (..)) @@ -77,7 +77,7 @@ roundtrip_all , Arbitrary' (HeaderHash blk) , Arbitrary' (LedgerState blk) , Arbitrary' (AnnTip blk) - , Arbitrary' (ConsensusState (BlockProtocol blk)) + , Arbitrary' (ChainDepState (BlockProtocol blk)) , ArbitraryWithVersion (BlockNodeToNodeVersion blk) blk , ArbitraryWithVersion (BlockNodeToNodeVersion blk) (Header blk) @@ -113,7 +113,7 @@ roundtrip_SerialiseDisk , Arbitrary' (Header blk) , Arbitrary' (LedgerState blk) , Arbitrary' (AnnTip blk) - , Arbitrary' (ConsensusState (BlockProtocol blk)) + , Arbitrary' (ChainDepState (BlockProtocol blk)) ) => CodecConfig blk -> (forall a. NestedCtxt_ blk Header a -> Dict (Eq a, Show a)) @@ -134,7 +134,7 @@ roundtrip_SerialiseDisk ccfg dictNestedHdr = , adjustOption (\(QuickCheckTests n) -> QuickCheckTests (1 `max` (div n 10))) $ rt (Proxy @(LedgerState blk)) "LedgerState" , rt (Proxy @(AnnTip blk)) "AnnTip" - , rt (Proxy @(ConsensusState (BlockProtocol blk))) "ConsensusState" + , rt (Proxy @(ChainDepState (BlockProtocol blk))) "ChainDepState" ] where rt :: forall a. (Arbitrary' a, EncodeDisk blk a, DecodeDisk blk a) diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs index 699c55d175a..4ead34a1163 100644 --- a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs @@ -369,6 +369,7 @@ singleNodeTestConfig = TopLevelConfig { , bftSignKey = SignKeyMockDSIGN 0 , bftVerKeys = Map.singleton (CoreId (CoreNodeId 0)) (VerKeyMockDSIGN 0) } + , configIndep = () , configLedger = eraParams , configBlock = TestBlockConfig numCoreNodes } diff --git a/ouroboros-consensus/src/Data/SOP/Strict.hs b/ouroboros-consensus/src/Data/SOP/Strict.hs index 5a8381fa123..4a5bdb72876 100644 --- a/ouroboros-consensus/src/Data/SOP/Strict.hs +++ b/ouroboros-consensus/src/Data/SOP/Strict.hs @@ -89,6 +89,15 @@ collapse_NP = go go Nil = [] go (K x :* xs) = x : go xs +ctraverse'_NP :: + forall c proxy xs f f' g. (All c xs, Applicative g) + => proxy c -> (forall a. c a => f a -> g (f' a)) -> NP f xs -> g (NP f' xs) +ctraverse'_NP _ f = go + where + go :: All c ys => NP f ys -> g (NP f' ys) + go Nil = pure Nil + go (x :* xs) = (:*) <$> f x <*> go xs + ctraverse__NP :: forall c proxy xs f g. (All c xs, Applicative g) => proxy c -> (forall a. c a => f a -> g ()) -> NP f xs -> g () @@ -114,6 +123,11 @@ instance HAp NP where instance HCollapse NP where hcollapse = collapse_NP +instance HSequence NP where + hctraverse' = ctraverse'_NP + htraverse' = hctraverse' (Proxy @Top) + hsequence' = htraverse' unComp + instance HTraverse_ NP where hctraverse_ = ctraverse__NP htraverse_ = traverse__NP diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Block/Forge.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Block/Forge.hs index 48d742f38ed..1a10ab03753 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Block/Forge.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Block/Forge.hs @@ -1,29 +1,32 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Block.Forge ( - CanForge (..) + -- * ForgeState + ForgeState(..) + , castForgeState + -- * CanForge + , CanForge(..) -- * MaintainForgeState , MaintainForgeState(..) , defaultMaintainForgeState + , defaultMaintainNoExtraForgeState + , hoistMaintainForgeState , castMaintainForgeState - -- * Infrastructure for dealing with state updates - , Update(..) - , runUpdate_ - , updateFromMVar - , liftUpdate - , coerceUpdate - , traceUpdate ) where -import Control.Tracer (Tracer, traceWith) -import Crypto.Random (MonadRandom) -import Data.Bifunctor (first) -import Data.Coerce +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic) import Cardano.Prelude (NoUnexpectedThunks) import Cardano.Slotting.Block @@ -34,38 +37,59 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util (Trivial (..), (..:)) +import Ouroboros.Consensus.Util.IOLike (IOLike) + +{------------------------------------------------------------------------------- + ForgeState +-------------------------------------------------------------------------------} + +data ForgeState blk = ForgeState { + chainIndepState :: !(ChainIndepState (BlockProtocol blk)) + , extraForgeState :: !(ExtraForgeState blk) + } + deriving (Generic) + +deriving instance ( NoUnexpectedThunks (ExtraForgeState blk) + , HasChainIndepState (BlockProtocol blk) + ) => NoUnexpectedThunks (ForgeState blk) +deriving instance ( Show (ExtraForgeState blk) + , HasChainIndepState (BlockProtocol blk) + ) => Show (ForgeState blk) + +castForgeState :: + ( ChainIndepState (BlockProtocol blk) ~ ChainIndepState (BlockProtocol blk') + , ExtraForgeState blk ~ ExtraForgeState blk' + ) + => ForgeState blk -> ForgeState blk' +castForgeState ForgeState {..} = ForgeState {..} {------------------------------------------------------------------------------- CanForge -------------------------------------------------------------------------------} -class ( NoUnexpectedThunks (ForgeState blk) - , Show (ForgeState blk) +class ( NoUnexpectedThunks (ExtraForgeState blk) + , ConsensusProtocol (BlockProtocol blk) + , Show (ExtraForgeState blk) ) => CanForge blk where - -- | (Chain-independent) state required to forge blocks - type ForgeState blk :: * - - -- Default to () - type ForgeState blk = () + -- | Extra block-specific state required to forge blocks in addition to the + -- protocol's chain independent state. + type ExtraForgeState blk :: * + type ExtraForgeState blk = () -- | Forge a new block -- - -- The forge state that is passed to `forgeBlock` will already have been + -- The forge state that is passed to 'forgeBlock' will already have been -- updated. - -- - -- TODO: This should be a pure function - -- forgeBlock - :: MonadRandom m - => TopLevelConfig blk + :: TopLevelConfig blk -> ForgeState blk -> BlockNo -- ^ Current block number -> TickedLedgerState blk -- ^ Current ledger -> [GenTx blk] -- ^ Txs to add in the block -> IsLeader (BlockProtocol blk) - -> m blk + -> blk {------------------------------------------------------------------------------- Maintaining the 'ForgeState' @@ -81,59 +105,72 @@ data MaintainForgeState (m :: * -> *) blk = MaintainForgeState { -- this function may have all kinds of things in its closure; for example, -- we might need access to some external hardware crypto hardware -- device. - , updateForgeState :: Update m (ForgeState blk) -- Lens into the node's state - -> SlotNo -- Current slot - -> m () + , updateForgeState :: ChainIndepStateConfig (BlockProtocol blk) + -> SlotNo -- Current wallclock slot + -> ForgeState blk + -> m (ForgeState blk) } -defaultMaintainForgeState :: (Monad m, ForgeState blk ~ ()) - => MaintainForgeState m blk +defaultMaintainForgeState :: + forall m blk. + ( Trivial (ChainIndepState (BlockProtocol blk)) + , Trivial (ExtraForgeState blk) + , Monad m + ) + => MaintainForgeState m blk defaultMaintainForgeState = MaintainForgeState { - initForgeState = () - , updateForgeState = \_ _ -> return () + initForgeState = ForgeState { + chainIndepState = trivial (Proxy @(ChainIndepState (BlockProtocol blk))) + , extraForgeState = trivial (Proxy @(ExtraForgeState blk)) + } + , updateForgeState = \_ _ -> return } -castMaintainForgeState :: ForgeState blk ~ ForgeState blk' - => MaintainForgeState m blk -> MaintainForgeState m blk' -castMaintainForgeState maintainForgeState = MaintainForgeState { - initForgeState = initForgeState maintainForgeState - , updateForgeState = updateForgeState maintainForgeState +-- | Default implementation of 'MaintainForgeState' in case there is no +-- 'ExtraForgeState'. 'updateForgeState' will just call +-- 'updateChainIndepState'. +defaultMaintainNoExtraForgeState :: + forall m blk. + ( Trivial (ExtraForgeState blk) + , ConsensusProtocol (BlockProtocol blk) + , IOLike m + ) + => ChainIndepState (BlockProtocol blk) + -> MaintainForgeState m blk +defaultMaintainNoExtraForgeState initChainIndepState = MaintainForgeState { + initForgeState = ForgeState { + chainIndepState = initChainIndepState + , extraForgeState = trivial (Proxy @(ExtraForgeState blk)) + } + , updateForgeState = \cfg slot (ForgeState chainIndepState extraForgeState) -> + (`ForgeState` extraForgeState) <$> + updateChainIndepState + (Proxy @(BlockProtocol blk)) + cfg + slot + chainIndepState } -{------------------------------------------------------------------------------- - Updating the state --------------------------------------------------------------------------------} - --- | Update a stateful value -newtype Update m a = Update { - -- | Update the value, and produce a result - runUpdate :: forall b. (a -> m (a, b)) -> m b +hoistMaintainForgeState :: + (forall x. m x -> n x) + -> MaintainForgeState m blk + -> MaintainForgeState n blk +hoistMaintainForgeState hoist MaintainForgeState {..} = MaintainForgeState { + initForgeState = initForgeState + , updateForgeState = hoist ..: updateForgeState } -runUpdate_ :: Functor m => Update m a -> (a -> m a) -> m () -runUpdate_ upd f = runUpdate upd (fmap (, ()) . f) - -updateFromMVar :: (MonadSTM m, MonadCatch m) => StrictMVar m a -> Update m a -updateFromMVar var = Update $ modifyMVar var - -liftUpdate :: Functor m - => (large -> small) - -> (small -> large -> large) - -> Update m large - -> Update m small -liftUpdate get set (Update update) = Update $ \f -> - update $ \large -> - first (flip set large) <$> (f (get large)) - -coerceUpdate :: (Functor m, Coercible a b) => Update m a -> Update m b -coerceUpdate = liftUpdate coerce (\new _old -> coerce new) - -traceUpdate :: forall m a. Monad m => Tracer m a -> Update m a -> Update m a -traceUpdate tracer upd = Update $ \f -> - runUpdate upd (aux f) - where - aux :: (a -> m (a, b)) -> a -> m (a, b) - aux f a = do - (a', b) <- f a - traceWith tracer a' - return (a', b) +castMaintainForgeState :: + ( ChainIndepStateConfig (BlockProtocol blk) ~ ChainIndepStateConfig (BlockProtocol blk') + , ChainIndepState (BlockProtocol blk) ~ ChainIndepState (BlockProtocol blk') + , ExtraForgeState blk ~ ExtraForgeState blk' + , Functor m + ) + => MaintainForgeState m blk -> MaintainForgeState m blk' +castMaintainForgeState maintainForgeState = MaintainForgeState { + initForgeState = castForgeState $ initForgeState maintainForgeState + , updateForgeState = \cfg slot -> + fmap castForgeState + . updateForgeState maintainForgeState cfg slot + . castForgeState + } diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Config.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Config.hs index b6e8ded0317..26c4750115e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Config.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Config.hs @@ -21,9 +21,10 @@ import Ouroboros.Consensus.Protocol.Abstract -- | The top-level node configuration data TopLevelConfig blk = TopLevelConfig { - configConsensus :: !(ConsensusConfig (BlockProtocol blk)) - , configLedger :: !(LedgerConfig blk) - , configBlock :: !(BlockConfig blk) + configConsensus :: !(ConsensusConfig (BlockProtocol blk)) + , configIndep :: !(ChainIndepStateConfig (BlockProtocol blk)) + , configLedger :: !(LedgerConfig blk) + , configBlock :: !(BlockConfig blk) } deriving (Generic) @@ -36,14 +37,18 @@ configSecurityParam :: ConsensusProtocol (BlockProtocol blk) => TopLevelConfig blk -> SecurityParam configSecurityParam = protocolSecurityParam . configConsensus -castTopLevelConfig :: ( Coercible (ConsensusConfig (BlockProtocol blk)) - (ConsensusConfig (BlockProtocol blk')) - , LedgerConfig blk ~ LedgerConfig blk' - , Coercible (BlockConfig blk) (BlockConfig blk') - ) - => TopLevelConfig blk -> TopLevelConfig blk' +castTopLevelConfig :: + ( Coercible (ConsensusConfig (BlockProtocol blk)) + (ConsensusConfig (BlockProtocol blk')) + , ChainIndepStateConfig (BlockProtocol blk) + ~ ChainIndepStateConfig (BlockProtocol blk') + , LedgerConfig blk ~ LedgerConfig blk' + , Coercible (BlockConfig blk) (BlockConfig blk') + ) + => TopLevelConfig blk -> TopLevelConfig blk' castTopLevelConfig TopLevelConfig{..} = TopLevelConfig{ configConsensus = coerce configConsensus + , configIndep = configIndep , configLedger = configLedger , configBlock = coerce configBlock } diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator.hs index e858cd8363a..004f582a6a2 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator.hs @@ -52,8 +52,9 @@ import Ouroboros.Consensus.HardFork.Combinator.AcrossEras as X -- Re-export types required to initialize 'ProtocolInfo' import Ouroboros.Consensus.HardFork.Combinator.AcrossEras as X - (PerEraBlockConfig (..), PerEraConsensusConfig (..), - PerEraForgeState (..)) + (PerEraBlockConfig (..), PerEraChainIndepState (..), + PerEraChainIndepStateConfig (..), + PerEraConsensusConfig (..), PerEraExtraForgeState (..)) -- Defines the various translation types required for concrete HFC instances import Ouroboros.Consensus.HardFork.Combinator.Translation as X @@ -86,9 +87,9 @@ import Ouroboros.Consensus.HardFork.Combinator.State as X -- * "Ouroboros.Consensus.HardFork.Combinator.State" -- This defines 'HardForkState', a wrapper around a 'Telescope'. We use this -- to define 'HardForkLedgerState', 'HardForkLedgerView' as well as --- 'HardForkConsensusState', but the type itself should mostly be internal --- to the hard fork combinator. We do export the constructor for it, as this --- may be required for serialisation code. +-- 'HardForkChainDepState', but the type itself should mostly be internal to +-- the hard fork combinator. We do export the constructor for it, as this may +-- be required for serialisation code. -- -- * "module Ouroboros.Consensus.HardFork.Combinator.State.Infra" -- This module is only separate from @.State@ to avoid some cyclic module diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs index 61fc161e902..44437f7aef4 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs @@ -25,7 +25,9 @@ module Ouroboros.Consensus.HardFork.Combinator.AcrossEras ( , PerEraLedgerConfig(..) , PerEraBlockConfig(..) , PerEraCodecConfig(..) - , PerEraForgeState(..) + , PerEraChainIndepState(..) + , PerEraChainIndepStateConfig(..) + , PerEraExtraForgeState(..) -- * Value for /one/ era , OneEraBlock(..) , OneEraHeader(..) @@ -69,7 +71,7 @@ import Ouroboros.Network.Block import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.TypeFamilyWrappers -import Ouroboros.Consensus.Util (allEqual) +import Ouroboros.Consensus.Util (Trivial, allEqual) import Ouroboros.Consensus.Util.Assert import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -83,12 +85,14 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Match as Match Value for /each/ era -------------------------------------------------------------------------------} -newtype PerEraConsensusConfig xs = PerEraConsensusConfig { getPerEraConsensusConfig :: NP WrapPartialConsensusConfig xs } -newtype PerEraChainSelConfig xs = PerEraChainSelConfig { getPerEraChainSelConfig :: NP WrapChainSelConfig xs } -newtype PerEraLedgerConfig xs = PerEraLedgerConfig { getPerEraLedgerConfig :: NP WrapPartialLedgerConfig xs } -newtype PerEraBlockConfig xs = PerEraBlockConfig { getPerEraBlockConfig :: NP BlockConfig xs } -newtype PerEraCodecConfig xs = PerEraCodecConfig { getPerEraCodecConfig :: NP CodecConfig xs } -newtype PerEraForgeState xs = PerEraForgeState { getPerEraForgeState :: NP WrapForgeState xs } +newtype PerEraConsensusConfig xs = PerEraConsensusConfig { getPerEraConsensusConfig :: NP WrapPartialConsensusConfig xs } +newtype PerEraChainSelConfig xs = PerEraChainSelConfig { getPerEraChainSelConfig :: NP WrapChainSelConfig xs } +newtype PerEraLedgerConfig xs = PerEraLedgerConfig { getPerEraLedgerConfig :: NP WrapPartialLedgerConfig xs } +newtype PerEraBlockConfig xs = PerEraBlockConfig { getPerEraBlockConfig :: NP BlockConfig xs } +newtype PerEraCodecConfig xs = PerEraCodecConfig { getPerEraCodecConfig :: NP CodecConfig xs } +newtype PerEraChainIndepState xs = PerEraChainIndepState { getPerEraChainIndepState :: NP WrapChainIndepState xs } +newtype PerEraChainIndepStateConfig xs = PerEraChainIndepStateConfig { getPerEraChainIndepStateConfig :: NP WrapChainIndepStateConfig xs } +newtype PerEraExtraForgeState xs = PerEraExtraForgeState { getPerEraExtraForgeState :: NP WrapExtraForgeState xs } {------------------------------------------------------------------------------- Value for /one/ era @@ -284,8 +288,14 @@ deriving via LiftNamedNP "PerEraChainSelConfig" WrapChainSelConfig xs deriving via LiftNamedNP "PerEraLedgerConfig" WrapPartialLedgerConfig xs instance CanHardFork xs => NoUnexpectedThunks (PerEraLedgerConfig xs) -deriving via LiftNamedNP "PerEraForgeState" WrapForgeState xs - instance CanHardFork xs => NoUnexpectedThunks (PerEraForgeState xs) +deriving via LiftNamedNP "PerEraChainIndepState" WrapChainIndepState xs + instance CanHardFork xs => NoUnexpectedThunks (PerEraChainIndepState xs) + +deriving via LiftNamedNP "PerEraChainIndepStateConfig" WrapChainIndepStateConfig xs + instance CanHardFork xs => NoUnexpectedThunks (PerEraChainIndepStateConfig xs) + +deriving via LiftNamedNP "PerEraExtraForgeState" WrapExtraForgeState xs + instance CanHardFork xs => NoUnexpectedThunks (PerEraExtraForgeState xs) deriving via LiftNamedNS "OneEraHeader" Header xs instance CanHardFork xs => NoUnexpectedThunks (OneEraHeader xs) @@ -315,30 +325,35 @@ deriving via LiftNamedMismatch "MismatchEraInfo" SingleEraInfo LedgerEraInfo xs Other instances -------------------------------------------------------------------------------} -deriving via LiftNS WrapTipInfo xs instance CanHardFork xs => Eq (OneEraTipInfo xs) -deriving via LiftNS WrapTipInfo xs instance CanHardFork xs => Show (OneEraTipInfo xs) +deriving via LiftNS WrapTipInfo xs instance CanHardFork xs => Eq (OneEraTipInfo xs) +deriving via LiftNS WrapTipInfo xs instance CanHardFork xs => Show (OneEraTipInfo xs) -deriving via LiftNS WrapEnvelopeErr xs instance CanHardFork xs => Eq (OneEraEnvelopeErr xs) -deriving via LiftNS WrapEnvelopeErr xs instance CanHardFork xs => Show (OneEraEnvelopeErr xs) +deriving via LiftNS WrapEnvelopeErr xs instance CanHardFork xs => Eq (OneEraEnvelopeErr xs) +deriving via LiftNS WrapEnvelopeErr xs instance CanHardFork xs => Show (OneEraEnvelopeErr xs) -deriving via LiftNS GenTx xs instance CanHardFork xs => Eq (OneEraGenTx xs) +deriving via LiftNS GenTx xs instance CanHardFork xs => Eq (OneEraGenTx xs) -deriving via LiftNS WrapGenTxId xs instance CanHardFork xs => Eq (OneEraGenTxId xs) -deriving via LiftNS WrapGenTxId xs instance CanHardFork xs => Ord (OneEraGenTxId xs) +deriving via LiftNS WrapGenTxId xs instance CanHardFork xs => Eq (OneEraGenTxId xs) +deriving via LiftNS WrapGenTxId xs instance CanHardFork xs => Ord (OneEraGenTxId xs) -deriving via LiftNS WrapLedgerErr xs instance CanHardFork xs => Eq (OneEraLedgerError xs) -deriving via LiftNS WrapLedgerErr xs instance CanHardFork xs => Show (OneEraLedgerError xs) +deriving via LiftNS WrapLedgerErr xs instance CanHardFork xs => Eq (OneEraLedgerError xs) +deriving via LiftNS WrapLedgerErr xs instance CanHardFork xs => Show (OneEraLedgerError xs) -deriving via LiftNS WrapValidationErr xs instance CanHardFork xs => Eq (OneEraValidationErr xs) -deriving via LiftNS WrapValidationErr xs instance CanHardFork xs => Show (OneEraValidationErr xs) +deriving via LiftNS WrapValidationErr xs instance CanHardFork xs => Eq (OneEraValidationErr xs) +deriving via LiftNS WrapValidationErr xs instance CanHardFork xs => Show (OneEraValidationErr xs) -deriving via LiftNP WrapForgeState xs instance CanHardFork xs => Show (PerEraForgeState xs) +deriving via LiftNP WrapChainIndepState xs instance CanHardFork xs => Show (PerEraChainIndepState xs) -deriving via LiftNS WrapApplyTxErr xs instance CanHardFork xs => Eq (OneEraApplyTxErr xs) +deriving via LiftNP WrapExtraForgeState xs instance CanHardFork xs => Show (PerEraExtraForgeState xs) + +deriving via LiftNS WrapApplyTxErr xs instance CanHardFork xs => Eq (OneEraApplyTxErr xs) deriving via LiftMismatch SingleEraInfo LedgerEraInfo xs instance CanHardFork xs => Eq (MismatchEraInfo xs) deriving via LiftMismatch SingleEraInfo LedgerEraInfo xs instance CanHardFork xs => Show (MismatchEraInfo xs) +deriving newtype instance All (Trivial `Compose` WrapChainIndepState) xs => Trivial (PerEraChainIndepState xs) +deriving newtype instance All (Trivial `Compose` WrapExtraForgeState) xs => Trivial (PerEraExtraForgeState xs) + {------------------------------------------------------------------------------- Show instances used in tests only -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index e0620f1793f..f7dab8aec97 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -11,6 +11,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Ouroboros.Consensus.HardFork.Combinator.Basics ( -- * Hard fork protocol, block, and ledger state @@ -46,6 +47,7 @@ import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras @@ -74,6 +76,34 @@ deriving stock instance CanHardFork xs => Show (LedgerState (HardForkBlock xs) deriving stock instance CanHardFork xs => Eq (LedgerState (HardForkBlock xs)) deriving newtype instance CanHardFork xs => NoUnexpectedThunks (LedgerState (HardForkBlock xs)) +{------------------------------------------------------------------------------- + Chain independent state +-------------------------------------------------------------------------------} + +instance CanHardFork xs => HasChainIndepState (HardForkProtocol xs) where + type ChainIndepStateConfig (HardForkProtocol xs) = PerEraChainIndepStateConfig xs + type ChainIndepState (HardForkProtocol xs) = PerEraChainIndepState xs + + -- Operations on the chain independent state + + updateChainIndepState _ cfg slot = + fmap PerEraChainIndepState + . hsequence' + . hczipWith proxySingle updateOne cfgs + . getPerEraChainIndepState + where + cfgs = getPerEraChainIndepStateConfig cfg + + updateOne :: + forall m blk. (SingleEraBlock blk, IOLike m) + => WrapChainIndepStateConfig blk + -> WrapChainIndepState blk + -> (m :.: WrapChainIndepState) blk + updateOne (WrapChainIndepStateConfig cfg') (WrapChainIndepState st) = + Comp $ + WrapChainIndepState <$> + updateChainIndepState (Proxy @(BlockProtocol blk)) cfg' slot st + {------------------------------------------------------------------------------- Protocol config -------------------------------------------------------------------------------} @@ -166,15 +196,21 @@ distribTopLevelConfig :: CanHardFork xs -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs distribTopLevelConfig ei TopLevelConfig{..} = - hczipWith3 proxySingle - (\cfgConsensus cfgLedger cfgBlock -> + hcpure proxySingle + (fn_4 (\cfgConsensus cfgIndep cfgLedger cfgBlock -> TopLevelConfig (completeConsensusConfig' ei cfgConsensus) + (unwrapChainIndepStateConfig cfgIndep) (completeLedgerConfig' ei cfgLedger) - cfgBlock) + cfgBlock)) + `hap` (getPerEraConsensusConfig $ hardForkConsensusConfigPerEra configConsensus) + `hap` + (getPerEraChainIndepStateConfig configIndep) + `hap` (getPerEraLedgerConfig $ hardForkLedgerConfigPerEra configLedger) + `hap` (getPerEraBlockConfig $ hardForkBlockConfigPerEra configBlock) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs index dc9be597617..2da0dc0448e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs @@ -27,7 +27,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Degenerate ( , CodecConfig(..) , NestedCtxt_(..) -- * Newtype wrappers - , DegenForkConsensusState(..) + , DegenForkChainDepState(..) , DegenForkHeaderHash(..) , DegenForkApplyTxErr(..) -- * Test support @@ -185,12 +185,12 @@ data DegenForkProtocol b type instance BlockProtocol (DegenFork b) = DegenForkProtocol b -newtype DegenForkConsensusState b = DCSt { - unDCSt :: ConsensusState (HardForkProtocol '[b]) +newtype DegenForkChainDepState b = DCSt { + unDCSt :: ChainDepState (HardForkProtocol '[b]) } -deriving instance SingleEraBlock b => Eq (DegenForkConsensusState b) -deriving instance SingleEraBlock b => Show (DegenForkConsensusState b) -deriving instance SingleEraBlock b => NoUnexpectedThunks (DegenForkConsensusState b) +deriving instance SingleEraBlock b => Eq (DegenForkChainDepState b) +deriving instance SingleEraBlock b => Show (DegenForkChainDepState b) +deriving instance SingleEraBlock b => NoUnexpectedThunks (DegenForkChainDepState b) instance SingleEraBlock b => ChainSelection (DegenForkProtocol b) where type ChainSelConfig (DegenForkProtocol b) = ChainSelConfig (HardForkProtocol '[b]) @@ -198,35 +198,42 @@ instance SingleEraBlock b => ChainSelection (DegenForkProtocol b) where preferCandidate _ = preferCandidate (Proxy @(HardForkProtocol '[b])) compareCandidates _ = compareCandidates (Proxy @(HardForkProtocol '[b])) +instance SingleEraBlock b => HasChainIndepState (DegenForkProtocol b) where + type ChainIndepStateConfig (DegenForkProtocol b) = ChainIndepStateConfig (HardForkProtocol '[b]) + type ChainIndepState (DegenForkProtocol b) = ChainIndepState (HardForkProtocol '[b]) + + -- Operations on the chain independent state + updateChainIndepState _ = updateChainIndepState (Proxy @(HardForkProtocol '[b])) + instance SingleEraBlock b => ConsensusProtocol (DegenForkProtocol b) where -- The reason for introducing a separate 'DegenForkProtocol' instead of: -- -- > type instance BlockProtocol (DegenFork b) = BlockProtocol (HardForkBlock '[b]) -- - -- is that we need to wrap the 'ConsensusState' in a newtype so that we can + -- is that we need to wrap the 'ChainDepState' in a newtype so that we can -- define non-orphan serialisation instances for it. The orphan instances - -- would be /bad orphans/, i.e., for @HardForkConsensusState '[b]@. - type ConsensusState (DegenForkProtocol b) = DegenForkConsensusState b - type ValidationErr (DegenForkProtocol b) = ValidationErr (HardForkProtocol '[b]) - type LedgerView (DegenForkProtocol b) = LedgerView (HardForkProtocol '[b]) - type CanBeLeader (DegenForkProtocol b) = CanBeLeader (HardForkProtocol '[b]) - type CannotLead (DegenForkProtocol b) = CannotLead (HardForkProtocol '[b]) - type IsLeader (DegenForkProtocol b) = IsLeader (HardForkProtocol '[b]) - type ValidateView (DegenForkProtocol b) = ValidateView (HardForkProtocol '[b]) + -- would be /bad orphans/, i.e., for @HardForkChainDepState '[b]@. + type ChainDepState (DegenForkProtocol b) = DegenForkChainDepState b + type ValidationErr (DegenForkProtocol b) = ValidationErr (HardForkProtocol '[b]) + type LedgerView (DegenForkProtocol b) = LedgerView (HardForkProtocol '[b]) + type CanBeLeader (DegenForkProtocol b) = CanBeLeader (HardForkProtocol '[b]) + type CannotLead (DegenForkProtocol b) = CannotLead (HardForkProtocol '[b]) + type IsLeader (DegenForkProtocol b) = IsLeader (HardForkProtocol '[b]) + type ValidateView (DegenForkProtocol b) = ValidateView (HardForkProtocol '[b]) -- Operations on the state - checkIsLeader (DConCfg cfg) canBeLeader tickedLedgerView (DCSt consensusState) = + checkIsLeader (DConCfg cfg) canBeLeader tickedLedgerView chainIndepState (DCSt chainDepState) = castLeaderCheck <$> - checkIsLeader cfg canBeLeader tickedLedgerView consensusState - updateConsensusState (DConCfg cfg) tickedLedgerView valView (DCSt consensusState) = - DCSt <$> updateConsensusState cfg tickedLedgerView valView consensusState - rewindConsensusState _ secParam pt (DCSt consensusState) = + checkIsLeader cfg canBeLeader tickedLedgerView chainIndepState chainDepState + updateChainDepState (DConCfg cfg) tickedLedgerView valView (DCSt chainDepState) = + DCSt <$> updateChainDepState cfg tickedLedgerView valView chainDepState + rewindChainDepState _ secParam pt (DCSt chainDepState) = DCSt <$> - rewindConsensusState + rewindChainDepState (Proxy @(HardForkProtocol '[b])) secParam pt - consensusState + chainDepState -- Straight-forward extensions protocolSecurityParam = protocolSecurityParam . unDConCfg @@ -342,13 +349,13 @@ instance NoHardForks b => CommonProtocolParams (DegenFork b) where maxTxSize (DLgr lgr) = maxTxSize (project lgr) instance NoHardForks b => CanForge (DegenFork b) where - type ForgeState (DegenFork b) = ForgeState (HardForkBlock '[b]) + type ExtraForgeState (DegenFork b) = ExtraForgeState (HardForkBlock '[b]) - forgeBlock cfg upd block (Ticked slot (DLgr lgr)) txs proof = - (DBlk . inject' (Proxy @(I b))) <$> + forgeBlock cfg forgeState block (Ticked slot (DLgr lgr)) txs proof = + DBlk . inject' (Proxy @(I b)) $ forgeBlock (projCfg cfg) - (project' (Proxy @(WrapForgeState b)) upd) + (project (castForgeState forgeState)) block (Ticked slot (project lgr)) (map (project . unDTx) txs) @@ -409,12 +416,12 @@ instance (SerialiseDiskConstraints b, NoHardForks b) decodeDisk = defaultDecodeDisk (Proxy @(Lazy.ByteString -> b)) instance (SerialiseDiskConstraints b, NoHardForks b) - => EncodeDisk (DegenFork b) (DegenForkConsensusState b) where - encodeDisk = defaultEncodeDisk (Proxy @(WrapConsensusState b)) + => EncodeDisk (DegenFork b) (DegenForkChainDepState b) where + encodeDisk = defaultEncodeDisk (Proxy @(WrapChainDepState b)) instance (SerialiseDiskConstraints b, NoHardForks b) - => DecodeDisk (DegenFork b) (DegenForkConsensusState b) where - decodeDisk = defaultDecodeDisk (Proxy @(WrapConsensusState b)) + => DecodeDisk (DegenFork b) (DegenForkChainDepState b) where + decodeDisk = defaultDecodeDisk (Proxy @(WrapChainDepState b)) instance (SerialiseDiskConstraints b, NoHardForks b) => EncodeDisk (DegenFork b) (LedgerState (DegenFork b)) where diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Forge.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Forge.hs index f099ebd3900..0f3cbb26a4b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Forge.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Forge.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -11,16 +12,15 @@ module Ouroboros.Consensus.HardFork.Combinator.Forge ( undistribMaintainForgeState ) where -import Crypto.Random (MonadRandom) -import Data.Coerce import Data.Functor.Product import Data.SOP.Strict import Cardano.Slotting.Slot (SlotNo) -import Ouroboros.Consensus.Block.Forge +import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.SOP @@ -32,7 +32,7 @@ import Ouroboros.Consensus.HardFork.Combinator.Protocol () import qualified Ouroboros.Consensus.HardFork.Combinator.State as State instance (CanHardFork xs, All CanForge xs) => CanForge (HardForkBlock xs) where - type ForgeState (HardForkBlock xs) = PerEraForgeState xs + type ExtraForgeState (HardForkBlock xs) = PerEraExtraForgeState xs forgeBlock cfg forgeState blockNo Ticked { tickedSlotNo, tickedLedgerState } @@ -49,11 +49,10 @@ instance (CanHardFork xs, All CanForge xs) => CanForge (HardForkBlock xs) where -- Although we get a list with transactions that each could be from -- a different era, we know they have been validated against the -- 'LedgerState', which means they __must__ be from the same era. - fmap (HardForkBlock . OneEraBlock) $ - hsequence $ + HardForkBlock . OneEraBlock $ hcpure (Proxy @CanForge) (fn_4 matchedForgeBlock) `hap` (distribTopLevelConfig ei cfg) - `hap` (getPerEraForgeState forgeState) + `hap` (distribForgeState forgeState) `hap` (partition_NS (map (getOneEraGenTx . getHardForkGenTx) txs)) `hap` (State.tip matched) where @@ -64,28 +63,55 @@ instance (CanHardFork xs, All CanForge xs) => CanForge (HardForkBlock xs) where -- | Unwraps all the layers needed for SOP and call 'forgeBlock'. matchedForgeBlock - :: forall m blk. (MonadRandom m, CanForge blk) + :: CanForge blk => TopLevelConfig blk - -> WrapForgeState blk + -> ForgeState blk -> ([] :.: GenTx) blk -> Product WrapIsLeader LedgerState blk - -> m blk + -> I blk matchedForgeBlock matchedCfg matchedForgeState (Comp matchedTxs) - (Pair matchedIsLeader matchedLedgerState) = + (Pair matchedIsLeader matchedLedgerState) = I $ forgeBlock matchedCfg - (unwrapForgeState matchedForgeState) + matchedForgeState blockNo (Ticked tickedSlotNo matchedLedgerState) matchedTxs (unwrapIsLeader matchedIsLeader) {------------------------------------------------------------------------------- - Maintaining the 'ForgeState' + Distributive properties -------------------------------------------------------------------------------} +distribForgeState :: + forall xs. SListI xs + => ForgeState (HardForkBlock xs) + -> NP ForgeState xs +distribForgeState = \ForgeState{..} -> + hzipWith + aux + (getPerEraChainIndepState chainIndepState) + (getPerEraExtraForgeState extraForgeState) + where + aux :: WrapChainIndepState blk -> WrapExtraForgeState blk -> ForgeState blk + aux chainIndepState extraForgeState = ForgeState { + chainIndepState = unwrapChainIndepState chainIndepState + , extraForgeState = unwrapExtraForgeState extraForgeState + } + +undistribForgeState :: + forall xs. SListI xs + => NP ForgeState xs + -> ForgeState (HardForkBlock xs) +undistribForgeState np = ForgeState { + chainIndepState = PerEraChainIndepState $ + hmap (WrapChainIndepState . chainIndepState) np + , extraForgeState = PerEraExtraForgeState $ + hmap (WrapExtraForgeState . extraForgeState) np + } + undistribMaintainForgeState :: forall xs m. (SListI xs, Monad m) => NP (MaintainForgeState m) xs @@ -95,35 +121,26 @@ undistribMaintainForgeState np = MaintainForgeState { , updateForgeState = updateForgeStateHardFork } where - initForgeStateHardFork :: PerEraForgeState xs - initForgeStateHardFork = - PerEraForgeState $ hmap (WrapForgeState . initForgeState) np + initForgeStateHardFork :: ForgeState (HardForkBlock xs) + initForgeStateHardFork = undistribForgeState $ hmap initForgeState np - updateForgeStateHardFork - :: Update m (ForgeState (HardForkBlock xs)) + updateForgeStateHardFork :: + ChainIndepStateConfig (BlockProtocol (HardForkBlock xs)) -> SlotNo - -> m () - updateForgeStateHardFork updateAll slotNo = - htraverse_ updateOne $ - hzipWith Pair np (distribUpdateForgeState updateAll) + -> ForgeState (HardForkBlock xs) + -> m (ForgeState (HardForkBlock xs)) + updateForgeStateHardFork cfg slot = + fmap undistribForgeState + . hsequence' + . hap updates + . distribForgeState where - updateOne - :: Product (MaintainForgeState m) (Update m :.: WrapForgeState) blk - -> m () - updateOne (Pair mfs (Comp update)) = - updateForgeState mfs (coerceUpdate update) slotNo + cfgs = getPerEraChainIndepStateConfig cfg -distribUpdateForgeState - :: forall xs m. (SListI xs, Functor m) - => Update m (ForgeState (HardForkBlock xs)) - -> NP (Update m :.: WrapForgeState) xs -distribUpdateForgeState updateAll = hliftA (Comp . mkSingleEraUpdate) lenses_NP - where - mkSingleEraUpdate - :: Lens WrapForgeState xs blk - -> Update m (WrapForgeState blk) - mkSingleEraUpdate Lens { getter, setter } = - liftUpdate - (getter . coerce) - (coerce . setter) - updateAll + updates :: NP (ForgeState -.-> m :.: ForgeState) xs + updates = + hzipWith + (\(WrapChainIndepStateConfig cfg') mfs -> + fn (Comp . updateForgeState mfs cfg' slot)) + cfgs + np diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index ace76b1e138..4c84cc7734b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs @@ -9,11 +9,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-orphans -fno-show-valid-hole-fits #-} module Ouroboros.Consensus.HardFork.Combinator.Protocol ( -- * Re-exports to keep 'Protocol.State' an internal module - HardForkConsensusState + HardForkChainDepState , HardForkIsLeader , HardForkCanBeLeader , HardForkValidationErr(..) @@ -37,7 +37,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers -import Ouroboros.Consensus.Util ((.:)) +import Ouroboros.Consensus.Util ((..:), (.:)) import Ouroboros.Consensus.Util.SOP import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -63,22 +63,22 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Match as Match ConsensusProtocol -------------------------------------------------------------------------------} -type HardForkConsensusState xs = HardForkState WrapConsensusState xs +type HardForkChainDepState xs = HardForkState WrapChainDepState xs instance CanHardFork xs => ConsensusProtocol (HardForkProtocol xs) where - type ConsensusState (HardForkProtocol xs) = HardForkConsensusState xs - type ValidationErr (HardForkProtocol xs) = HardForkValidationErr xs - type LedgerView (HardForkProtocol xs) = HardForkLedgerView xs - type CanBeLeader (HardForkProtocol xs) = HardForkCanBeLeader xs - type CannotLead (HardForkProtocol xs) = HardForkCannotLead xs - type IsLeader (HardForkProtocol xs) = HardForkIsLeader xs - type ValidateView (HardForkProtocol xs) = OneEraValidateView xs + type ChainDepState (HardForkProtocol xs) = HardForkChainDepState xs + type ValidationErr (HardForkProtocol xs) = HardForkValidationErr xs + type LedgerView (HardForkProtocol xs) = HardForkLedgerView xs + type CanBeLeader (HardForkProtocol xs) = HardForkCanBeLeader xs + type CannotLead (HardForkProtocol xs) = HardForkCannotLead xs + type IsLeader (HardForkProtocol xs) = HardForkIsLeader xs + type ValidateView (HardForkProtocol xs) = OneEraValidateView xs -- Operations on the state - checkIsLeader = check - updateConsensusState = update - rewindConsensusState _ = rewind + checkIsLeader = check + updateChainDepState = update + rewindChainDepState _ = rewind -- -- Straight-forward extensions @@ -148,19 +148,21 @@ check :: forall m xs. (MonadRandom m, CanHardFork xs) => ConsensusConfig (HardForkProtocol xs) -> HardForkCanBeLeader xs -> Ticked (HardForkLedgerView xs) - -> HardForkConsensusState xs - -> m (LeaderCheck (HardForkProtocol xs)) -check cfg@HardForkConsensusConfig{..} canBeLeader (Ticked slot ledgerView) = + -> ChainIndepState (HardForkProtocol xs) + -> ChainDepState (HardForkProtocol xs) + -> m (LeaderCheck (HardForkProtocol xs)) +check cfg@HardForkConsensusConfig{..} canBeLeader (Ticked slot ledgerView) cis = fmap distrib . hsequence' . State.tip . State.align (translateConsensus ei cfg) - (hczipWith + (hczipWith3 proxySingle - (fn_2 .: checkOne ei slot) + (fn_2 ..: checkOne ei slot) cfgs - (fromOptNP canBeLeader)) + (fromOptNP canBeLeader) + (getPerEraChainIndepState cis)) (hardForkLedgerViewPerEra ledgerView) where cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra @@ -186,12 +188,14 @@ checkOne :: (MonadRandom m, SingleEraBlock blk) -> SlotNo -> WrapPartialConsensusConfig blk -> (Maybe :.: WrapCanBeLeader) blk + -> WrapChainIndepState blk -> WrapLedgerView blk - -> WrapConsensusState blk + -> WrapChainDepState blk -> (m :.: WrapLeaderCheck) blk checkOne ei slot cfg (Comp mCanBeLeader) + (WrapChainIndepState chainIndepState) ledgerView - (WrapConsensusState consensusState) = Comp $ WrapLeaderCheck <$> + (WrapChainDepState chainDepState) = Comp $ WrapLeaderCheck <$> case mCanBeLeader of Nothing -> return NotLeader @@ -200,7 +204,8 @@ checkOne ei slot cfg (Comp mCanBeLeader) (completeConsensusConfig' ei cfg) (unwrapCanBeLeader canBeLeader) (Ticked slot (unwrapLedgerView ledgerView)) - consensusState + chainIndepState + chainDepState {------------------------------------------------------------------------------- Rolling forward and backward @@ -217,30 +222,30 @@ data HardForkValidationErr xs = rewind :: (CanHardFork xs, Serialise (HeaderHash hdr)) => SecurityParam -> Point hdr - -> HardForkConsensusState xs - -> Maybe (HardForkConsensusState xs) + -> HardForkChainDepState xs + -> Maybe (HardForkChainDepState xs) rewind k p = -- Using just the 'SlotNo' is okay: no EBBs near transition State.retractToSlot (pointSlot p) >=> (hsequence' . hcmap proxySingle rewindOne) where rewindOne :: forall blk. SingleEraBlock blk - => WrapConsensusState blk - -> (Maybe :.: WrapConsensusState) blk - rewindOne (WrapConsensusState st) = Comp $ - WrapConsensusState <$> - rewindConsensusState (Proxy @(BlockProtocol blk)) k p st + => WrapChainDepState blk + -> (Maybe :.: WrapChainDepState) blk + rewindOne (WrapChainDepState st) = Comp $ + WrapChainDepState <$> + rewindChainDepState (Proxy @(BlockProtocol blk)) k p st update :: forall xs. CanHardFork xs => ConsensusConfig (HardForkProtocol xs) -> Ticked (HardForkLedgerView xs) -> OneEraValidateView xs - -> HardForkConsensusState xs - -> Except (HardForkValidationErr xs) (HardForkConsensusState xs) + -> HardForkChainDepState xs + -> Except (HardForkValidationErr xs) (HardForkChainDepState xs) update cfg@HardForkConsensusConfig{..} (Ticked slot ledgerView) (OneEraValidateView view) - consensusState = + chainDepState = case State.match view (hardForkLedgerViewPerEra ledgerView) of Left mismatch -> throwError $ HardForkValidationErrWrongEra . MismatchEraInfo $ @@ -252,7 +257,7 @@ update cfg@HardForkConsensusConfig{..} (translateConsensus ei cfg) (hczipWith proxySingle (fn_2 .: updateEra ei slot) cfgs injections) matched - $ consensusState + $ chainDepState where cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra ei = State.epochInfoLedgerView hardForkConsensusConfigShape ledgerView @@ -263,18 +268,18 @@ updateEra :: forall xs blk. SingleEraBlock blk -> WrapPartialConsensusConfig blk -> Injection WrapValidationErr xs blk -> Product WrapValidateView WrapLedgerView blk - -> WrapConsensusState blk - -> (Except (HardForkValidationErr xs) :.: WrapConsensusState) blk + -> WrapChainDepState blk + -> (Except (HardForkValidationErr xs) :.: WrapChainDepState) blk updateEra ei slot cfg injectErr (Pair (WrapValidateView view) ledgerView) - (WrapConsensusState consensusState) = Comp $ + (WrapChainDepState chainDepState) = Comp $ withExcept (injectValidationErr injectErr) $ - fmap WrapConsensusState $ - updateConsensusState + fmap WrapChainDepState $ + updateChainDepState (completeConsensusConfig' ei cfg) (Ticked slot (unwrapLedgerView ledgerView)) view - consensusState + chainDepState {------------------------------------------------------------------------------- Auxiliary @@ -287,10 +292,10 @@ ledgerInfo _ = LedgerEraInfo $ singleEraInfo (Proxy @blk) translateConsensus :: forall xs. CanHardFork xs => EpochInfo Identity -> ConsensusConfig (HardForkProtocol xs) - -> InPairs (Translate WrapConsensusState) xs + -> InPairs (Translate WrapChainDepState) xs translateConsensus ei HardForkConsensusConfig{..} = InPairs.requiringBoth cfgs $ - translateConsensusState hardForkEraTranslation + translateChainDepState hardForkEraTranslation where pcfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra cfgs = hcmap proxySingle (completeConsensusConfig'' ei) pcfgs diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseDisk.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseDisk.hs index bc67d8c8d13..7ec7a6e1ebc 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseDisk.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseDisk.hs @@ -123,20 +123,20 @@ instance SerialiseHFC xs cfgs = getPerEraCodecConfig (hardForkCodecConfigPerEra cfg) instance SerialiseHFC xs - => EncodeDisk (HardForkBlock xs) (HardForkConsensusState xs) where + => EncodeDisk (HardForkBlock xs) (HardForkChainDepState xs) where encodeDisk cfg = encodeTelescope (hcmap pSHFC (fn . aux) cfgs) where cfgs = getPerEraCodecConfig (hardForkCodecConfigPerEra cfg) aux :: SerialiseDiskConstraints blk - => CodecConfig blk -> WrapConsensusState blk -> K Encoding blk - aux cfg' (WrapConsensusState st) = K $ encodeDisk cfg' st + => CodecConfig blk -> WrapChainDepState blk -> K Encoding blk + aux cfg' (WrapChainDepState st) = K $ encodeDisk cfg' st instance SerialiseHFC xs - => DecodeDisk (HardForkBlock xs) (HardForkConsensusState xs) where + => DecodeDisk (HardForkBlock xs) (HardForkChainDepState xs) where decodeDisk cfg = - decodeTelescope (hcmap pSHFC (Comp . fmap WrapConsensusState . decodeDisk) cfgs) + decodeTelescope (hcmap pSHFC (Comp . fmap WrapChainDepState . decodeDisk) cfgs) where cfgs = getPerEraCodecConfig (hardForkCodecConfigPerEra cfg) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Translation.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Translation.hs index bd3130bec7f..8ec5cb42e65 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Translation.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Translation.hs @@ -21,16 +21,16 @@ import Ouroboros.Consensus.HardFork.Combinator.Util.InPairs -------------------------------------------------------------------------------} data EraTranslation xs = EraTranslation { - translateLedgerState :: InPairs (RequiringBoth WrapLedgerConfig (Translate LedgerState)) xs - , translateLedgerView :: InPairs (RequiringBoth WrapLedgerConfig (Translate WrapLedgerView)) xs - , translateConsensusState :: InPairs (RequiringBoth WrapConsensusConfig (Translate WrapConsensusState)) xs + translateLedgerState :: InPairs (RequiringBoth WrapLedgerConfig (Translate LedgerState)) xs + , translateLedgerView :: InPairs (RequiringBoth WrapLedgerConfig (Translate WrapLedgerView)) xs + , translateChainDepState :: InPairs (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState)) xs } deriving NoUnexpectedThunks via OnlyCheckIsWHNF "EraTranslation" (EraTranslation xs) trivialEraTranslation :: EraTranslation '[blk] trivialEraTranslation = EraTranslation { - translateLedgerState = PNil - , translateLedgerView = PNil - , translateConsensusState = PNil + translateLedgerState = PNil + , translateLedgerView = PNil + , translateChainDepState = PNil } diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Unary.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Unary.hs index 873db760bdf..3977f698d7d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Unary.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Unary.hs @@ -197,11 +197,19 @@ instance Isomorphic LedgerState where project = defaultProjectSt inject = defaultInjectSt -instance Isomorphic WrapConsensusState where +instance Isomorphic WrapChainDepState where project = defaultProjectSt inject = defaultInjectSt -instance Isomorphic WrapForgeState where +instance Isomorphic WrapChainIndepState where + project = defaultProjectNP + inject = defaultInjectNP + +instance Isomorphic WrapChainIndepStateConfig where + project = defaultProjectNP + inject = defaultInjectNP + +instance Isomorphic WrapExtraForgeState where project = defaultProjectNP inject = defaultInjectNP @@ -253,6 +261,7 @@ instance Isomorphic TopLevelConfig where => TopLevelConfig (HardForkBlock '[blk]) -> TopLevelConfig blk project TopLevelConfig{..} = TopLevelConfig{ configConsensus = auxConsensus configConsensus + , configIndep = auxIndep configIndep , configLedger = auxLedger configLedger , configBlock = project configBlock } @@ -282,10 +291,15 @@ instance Isomorphic TopLevelConfig where . getPerEraConsensusConfig . hardForkConsensusConfigPerEra + auxIndep :: ChainIndepStateConfig (BlockProtocol (HardForkBlock '[blk])) + -> ChainIndepStateConfig (BlockProtocol blk) + auxIndep = project' (Proxy @(WrapChainIndepStateConfig blk)) + inject :: forall blk. NoHardForks blk => TopLevelConfig blk -> TopLevelConfig (HardForkBlock '[blk]) inject tlc@TopLevelConfig{..} = TopLevelConfig{ configConsensus = auxConsensus configConsensus + , configIndep = auxIndep configIndep , configLedger = auxLedger configLedger , configBlock = inject configBlock } @@ -312,6 +326,10 @@ instance Isomorphic TopLevelConfig where :* Nil } + auxIndep :: ChainIndepStateConfig (BlockProtocol blk) + -> ChainIndepStateConfig (BlockProtocol (HardForkBlock '[blk])) + auxIndep = inject' (Proxy @(WrapChainIndepStateConfig blk)) + {------------------------------------------------------------------------------- Various kinds of records -------------------------------------------------------------------------------} @@ -320,7 +338,7 @@ instance Isomorphic HeaderState where project :: forall blk. NoHardForks blk => HeaderState (HardForkBlock '[blk]) -> HeaderState blk project HeaderState{..} = HeaderState { - headerStateConsensus = project' (Proxy @(WrapConsensusState blk)) headerStateConsensus + headerStateConsensus = project' (Proxy @(WrapChainDepState blk)) headerStateConsensus , headerStateTips = project <$> headerStateTips , headerStateAnchor = project <$> headerStateAnchor } @@ -328,7 +346,7 @@ instance Isomorphic HeaderState where inject :: forall blk. NoHardForks blk => HeaderState blk -> HeaderState (HardForkBlock '[blk]) inject HeaderState{..} = HeaderState { - headerStateConsensus = inject' (Proxy @(WrapConsensusState blk)) headerStateConsensus + headerStateConsensus = inject' (Proxy @(WrapChainDepState blk)) headerStateConsensus , headerStateTips = inject <$> headerStateTips , headerStateAnchor = inject <$> headerStateAnchor } @@ -344,34 +362,49 @@ instance Isomorphic ExtLedgerState where , headerState = inject headerState } +instance Isomorphic ForgeState where + project :: forall blk. NoHardForks blk + => ForgeState (HardForkBlock '[blk]) -> ForgeState blk + project ForgeState{..} = ForgeState { + chainIndepState = project' (Proxy @(WrapChainIndepState blk)) chainIndepState + , extraForgeState = project' (Proxy @(WrapExtraForgeState blk)) extraForgeState + } + + inject :: forall blk. NoHardForks blk + => ForgeState blk -> ForgeState (HardForkBlock '[blk]) + inject ForgeState{..} = ForgeState { + chainIndepState = inject' (Proxy @(WrapChainIndepState blk)) chainIndepState + , extraForgeState = inject' (Proxy @(WrapExtraForgeState blk)) extraForgeState + } + instance Functor m => Isomorphic (MaintainForgeState m) where project :: forall blk. NoHardForks blk => MaintainForgeState m (HardForkBlock '[blk]) -> MaintainForgeState m blk project mfs = MaintainForgeState { - initForgeState = project' (Proxy @(WrapForgeState blk)) $ initForgeState mfs - , updateForgeState = updateForgeState mfs . liftUpdate get set + initForgeState = project $ initForgeState mfs + , updateForgeState = \cfg slotNo -> + fmap project + . updateForgeState + mfs + (inject' (Proxy @(WrapChainIndepStateConfig blk)) cfg) + slotNo + . inject } - where - get :: ForgeState blk -> PerEraForgeState '[blk] - get = inject' (Proxy @(WrapForgeState blk)) - - set :: PerEraForgeState '[blk] -> ForgeState blk -> ForgeState blk - set = const . project' (Proxy @(WrapForgeState blk)) inject :: forall blk. NoHardForks blk => MaintainForgeState m blk -> MaintainForgeState m (HardForkBlock '[blk]) inject mfs = MaintainForgeState { - initForgeState = inject' (Proxy @(WrapForgeState blk)) $ initForgeState mfs - , updateForgeState = updateForgeState mfs . liftUpdate get set + initForgeState = inject $ initForgeState mfs + , updateForgeState = \cfg slotNo -> + fmap inject + . updateForgeState + mfs + (project' (Proxy @(WrapChainIndepStateConfig blk)) cfg) + slotNo + . project } - where - get :: PerEraForgeState '[blk] -> ForgeState blk - get = project' (Proxy @(WrapForgeState blk)) - - set :: ForgeState blk -> PerEraForgeState '[blk] -> PerEraForgeState '[blk] - set = const . inject' (Proxy @(WrapForgeState blk)) instance Isomorphic AnnTip where project :: forall blk. NoHardForks blk => AnnTip (HardForkBlock '[blk]) -> AnnTip blk diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Util/Telescope.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Util/Telescope.hs index e4a29278c43..2c24e3c05e2 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Util/Telescope.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Util/Telescope.hs @@ -338,7 +338,7 @@ newtype Retract m g f x y = Retract { retractWith :: g x -> f y -> m (f x) } -- state. When we rewind the consensus state, we might cross a hard fork -- transition point. So we first /retract/ the telescope /to/ the era containing -- the slot number that we want to rewind to, and only then call --- 'rewindConsensusState' on that era. Of course, retraction may fail (we +-- 'rewindChainDepState' on that era. Of course, retraction may fail (we -- might not /have/ past consensus state to rewind to anymore); this failure -- would require a choice for a particular monad @m@. retract :: forall m h g f xs. Monad m diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs index 83f486cea68..708e19d5e5d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs @@ -147,7 +147,7 @@ getAnnTip hdr = AnnTip { -- See 'validateHeader' for details data HeaderState blk = HeaderState { -- | Protocol-specific state - headerStateConsensus :: !(ConsensusState (BlockProtocol blk)) + headerStateConsensus :: !(ChainDepState (BlockProtocol blk)) -- | The most recent @k@ tips , headerStateTips :: !(StrictSeq (AnnTip blk)) @@ -165,7 +165,7 @@ headerStateTip HeaderState{..} = headerStatePush :: forall blk. SecurityParam - -> ConsensusState (BlockProtocol blk) + -> ChainDepState (BlockProtocol blk) -> AnnTip blk -> HeaderState blk -> HeaderState blk @@ -188,14 +188,14 @@ deriving instance (BlockSupportsProtocol blk, HasAnnTip blk) => NoUnexpectedThunks (HeaderState blk) deriving instance ( BlockSupportsProtocol blk , HasAnnTip blk - , Eq (ConsensusState (BlockProtocol blk)) + , Eq (ChainDepState (BlockProtocol blk)) ) => Eq (HeaderState blk) -genesisHeaderState :: ConsensusState (BlockProtocol blk) -> HeaderState blk +genesisHeaderState :: ChainDepState (BlockProtocol blk) -> HeaderState blk genesisHeaderState state = HeaderState state Seq.Empty Origin -castHeaderState :: ( Coercible (ConsensusState (BlockProtocol blk )) - (ConsensusState (BlockProtocol blk')) +castHeaderState :: ( Coercible (ChainDepState (BlockProtocol blk )) + (ChainDepState (BlockProtocol blk')) , TipInfo blk ~ TipInfo blk' ) => HeaderState blk -> HeaderState blk' @@ -224,13 +224,13 @@ rewindHeaderState :: forall blk. -> Point blk -> HeaderState blk -> Maybe (HeaderState blk) rewindHeaderState cfg p HeaderState{..} = do - consensusState' <- rewindConsensusState - (Proxy @(BlockProtocol blk)) - (configSecurityParam cfg) - p - headerStateConsensus + chainDepState' <- rewindChainDepState + (Proxy @(BlockProtocol blk)) + (configSecurityParam cfg) + p + headerStateConsensus return $ HeaderState { - headerStateConsensus = consensusState' + headerStateConsensus = chainDepState' , headerStateTips = Seq.dropWhileR rolledBack headerStateTips , headerStateAnchor = headerStateAnchor } @@ -450,15 +450,15 @@ validateHeader :: (BlockSupportsProtocol blk, ValidateEnvelope blk) validateHeader cfg ledgerView hdr st = do withExcept HeaderEnvelopeError $ validateEnvelope cfg ledgerView (headerStateTip st) hdr - consensusState' <- withExcept HeaderProtocolError $ - updateConsensusState - (configConsensus cfg) - ledgerView - (validateView (configBlock cfg) hdr) - (headerStateConsensus st) + chainDepState' <- withExcept HeaderProtocolError $ + updateChainDepState + (configConsensus cfg) + ledgerView + (validateView (configBlock cfg) hdr) + (headerStateConsensus st) return $ headerStatePush (configSecurityParam cfg) - consensusState' + chainDepState' (getAnnTip hdr) st @@ -540,24 +540,24 @@ decodeAnnTipIsEBB decodeHash = do decodeInfo :: forall s. Decoder s IsEBB decodeInfo = decode -encodeHeaderState :: (ConsensusState (BlockProtocol blk) -> Encoding) +encodeHeaderState :: (ChainDepState (BlockProtocol blk) -> Encoding) -> (AnnTip blk -> Encoding) -> (HeaderState blk -> Encoding) -encodeHeaderState encodeConsensusState +encodeHeaderState encodeChainDepState encodeAnnTip' HeaderState{..} = mconcat [ encodeListLen 3 - , encodeConsensusState headerStateConsensus + , encodeChainDepState headerStateConsensus , Util.CBOR.encodeSeq encodeAnnTip' headerStateTips , Util.CBOR.encodeWithOrigin encodeAnnTip' headerStateAnchor ] -decodeHeaderState :: (forall s. Decoder s (ConsensusState (BlockProtocol blk))) +decodeHeaderState :: (forall s. Decoder s (ChainDepState (BlockProtocol blk))) -> (forall s. Decoder s (AnnTip blk)) -> (forall s. Decoder s (HeaderState blk)) -decodeHeaderState decodeConsensusState decodeAnnTip' = do +decodeHeaderState decodeChainDepState decodeAnnTip' = do enforceSize "HeaderState" 3 - headerStateConsensus <- decodeConsensusState + headerStateConsensus <- decodeChainDepState headerStateTips <- Util.CBOR.decodeSeq decodeAnnTip' headerStateAnchor <- Util.CBOR.decodeWithOrigin decodeAnnTip' return HeaderState{..} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs index b55fc9d97b1..a9f55fc0d29 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs @@ -160,6 +160,7 @@ data instance BlockConfig (DualBlock m a) = DualBlockConfig { dualTopLevelConfigMain :: TopLevelConfig (DualBlock m a) -> TopLevelConfig m dualTopLevelConfigMain TopLevelConfig{..} = TopLevelConfig{ configConsensus = configConsensus + , configIndep = configIndep , configLedger = dualLedgerConfigMain configLedger , configBlock = dualBlockConfigMain configBlock } diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Extended.hs index 6b2d0b0e2cf..7feb0b30e40 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Extended.hs @@ -74,7 +74,7 @@ instance LedgerSupportsProtocol blk => NoUnexpectedThunks (ExtLedgerState blk) w showTypeOf _ = show $ typeRep (Proxy @(ExtLedgerState blk)) deriving instance ( LedgerSupportsProtocol blk - , Eq (ConsensusState (BlockProtocol blk)) + , Eq (ChainDepState (BlockProtocol blk)) ) => Eq (ExtLedgerState blk) -- | Lemma: @@ -182,11 +182,11 @@ instance ( LedgerSupportsProtocol blk -------------------------------------------------------------------------------} encodeExtLedgerState :: (LedgerState blk -> Encoding) - -> (ConsensusState (BlockProtocol blk) -> Encoding) + -> (ChainDepState (BlockProtocol blk) -> Encoding) -> (AnnTip blk -> Encoding) -> ExtLedgerState blk -> Encoding encodeExtLedgerState encodeLedgerState - encodeConsensusState + encodeChainDepState encodeAnnTip ExtLedgerState{..} = mconcat [ encodeLedgerState ledgerState @@ -194,22 +194,22 @@ encodeExtLedgerState encodeLedgerState ] where encodeHeaderState' = encodeHeaderState - encodeConsensusState + encodeChainDepState encodeAnnTip decodeExtLedgerState :: (forall s. Decoder s (LedgerState blk)) - -> (forall s. Decoder s (ConsensusState (BlockProtocol blk))) + -> (forall s. Decoder s (ChainDepState (BlockProtocol blk))) -> (forall s. Decoder s (AnnTip blk)) -> (forall s. Decoder s (ExtLedgerState blk)) decodeExtLedgerState decodeLedgerState - decodeConsensusState + decodeChainDepState decodeAnnTip = do ledgerState <- decodeLedgerState headerState <- decodeHeaderState' return ExtLedgerState{..} where decodeHeaderState' = decodeHeaderState - decodeConsensusState + decodeChainDepState decodeAnnTip {------------------------------------------------------------------------------- @@ -219,8 +219,8 @@ decodeExtLedgerState decodeLedgerState castExtLedgerState :: ( Coercible (LedgerState blk) (LedgerState blk') - , Coercible (ConsensusState (BlockProtocol blk)) - (ConsensusState (BlockProtocol blk')) + , Coercible (ChainDepState (BlockProtocol blk)) + (ChainDepState (BlockProtocol blk')) , TipInfo blk ~ TipInfo blk' ) => ExtLedgerState blk -> ExtLedgerState blk' diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index 1443762465d..32eaa5ca592 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -153,10 +153,9 @@ bracketChainSyncClient tracer ChainDbView { getIsInvalidBlock } varCandidates -- selection. -- -- We also validate the headers of a candidate chain by advancing the --- 'ConsensusState' with the headers, which returns an error when validation --- failed. Thus, in addition to the chain fragment of each candidate, we --- also store a 'ConsensusState' corresponding to the head of the candidate --- chain. +-- 'ChainDepState' with the headers, which returns an error when validation +-- failed. Thus, in addition to the chain fragment of each candidate, we also +-- store a 'ChainDepState' corresponding to the head of the candidate chain. -- -- We must keep the candidate chain synchronised with the corresponding -- upstream chain. The upstream node's chain might roll forward or diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/BlockProduction.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/BlockProduction.hs index 45f627cdfcb..bccf5d9aea9 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/BlockProduction.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/BlockProduction.hs @@ -10,7 +10,7 @@ module Ouroboros.Consensus.Node.BlockProduction ( , defaultGetLeaderProof ) where -import Control.Tracer (Tracer) +import Control.Tracer (Tracer, traceWith) import Crypto.Random (MonadRandom) import Ouroboros.Network.Block @@ -27,7 +27,7 @@ data BlockProduction m blk = BlockProduction { -- | Check if we should produce a block getLeaderProof :: Tracer m (ForgeState blk) -> Ticked (LedgerView (BlockProtocol blk)) - -> ConsensusState (BlockProtocol blk) + -> ChainDepState (BlockProtocol blk) -> m (LeaderCheck (BlockProtocol blk)) -- | Produce a block @@ -55,38 +55,49 @@ blockProductionIO :: forall blk. (BlockSupportsProtocol blk, CanForge blk) -> IO (BlockProduction IO blk) blockProductionIO cfg canBeLeader mfs = do varForgeState <- newMVar (initForgeState mfs) - let upd :: Update IO (ForgeState blk) - upd = updateFromMVar varForgeState return $ BlockProduction { - getLeaderProof = \tracer -> + getLeaderProof = defaultGetLeaderProof cfg canBeLeader mfs - (traceUpdate tracer upd) + varForgeState , produceBlock = \bno ledgerState txs proof -> do forgeState <- readMVar varForgeState - forgeBlock cfg forgeState bno ledgerState txs proof + return $ forgeBlock cfg forgeState bno ledgerState txs proof } {------------------------------------------------------------------------------- Get leader proof -------------------------------------------------------------------------------} -defaultGetLeaderProof :: ( MonadRandom m - , ConsensusProtocol (BlockProtocol blk) - ) - => TopLevelConfig blk - -> CanBeLeader (BlockProtocol blk) - -> MaintainForgeState m blk - -> Update m (ForgeState blk) - -> Ticked (LedgerView (BlockProtocol blk)) - -> ConsensusState (BlockProtocol blk) - -> m (LeaderCheck (BlockProtocol blk)) -defaultGetLeaderProof cfg proof mfs upd lgrSt consensusSt = do - updateForgeState mfs upd (tickedSlotNo lgrSt) +defaultGetLeaderProof :: + ( MonadSTM m + , MonadCatch m + , MonadRandom m + , ConsensusProtocol (BlockProtocol blk) + ) + => TopLevelConfig blk + -> CanBeLeader (BlockProtocol blk) + -> MaintainForgeState m blk + -> StrictMVar m (ForgeState blk) + -> Tracer m (ForgeState blk) + -> Ticked (LedgerView (BlockProtocol blk)) + -> ChainDepState (BlockProtocol blk) + -> m (LeaderCheck (BlockProtocol blk)) +defaultGetLeaderProof cfg proof mfs varForgeState tracer lgrSt chainDepSt = do + forgeState' <- modifyMVar varForgeState $ \forgeState -> do + forgeState' <- + updateForgeState + mfs + (configIndep cfg) + (tickedSlotNo lgrSt) + forgeState + return (forgeState', forgeState') + traceWith tracer forgeState' checkIsLeader (configConsensus cfg) proof lgrSt - consensusSt + (chainIndepState forgeState') + chainDepSt diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo.hs index 8f71e22908f..04006ed41f6 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo.hs @@ -65,12 +65,12 @@ castProtocolInfo (ConsensusConfig (BlockProtocol blk')) , Coercible (BlockConfig blk) (BlockConfig blk') , Coercible (LedgerState blk) (LedgerState blk') - , Coercible (ConsensusState (BlockProtocol blk)) - (ConsensusState (BlockProtocol blk')) - , CanBeLeader (BlockProtocol blk) ~ CanBeLeader (BlockProtocol blk') + , Coercible (ChainDepState (BlockProtocol blk)) + (ChainDepState (BlockProtocol blk')) , LedgerConfig blk ~ LedgerConfig blk' , TipInfo blk ~ TipInfo blk' , ForgeState blk ~ ForgeState blk' + , Functor m ) => ProtocolInfo m blk -> ProtocolInfo m blk' diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs index 2afe63531d2..c5e347a858b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs @@ -115,8 +115,8 @@ showTracers :: ( Show blk , Show (GenTxId blk) , Show (ApplyTxErr blk) , Show (Header blk) + , Show (ExtraForgeState blk) , Show remotePeer - , Show (ForgeState blk) , LedgerSupportsProtocol blk ) => Tracer m String -> Tracers m remotePeer localPeer blk diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs index 6c038736947..82ef519cc44 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs @@ -6,6 +6,7 @@ module Ouroboros.Consensus.Protocol.Abstract ( -- * Abstract definition of the Ouroboros protocol ConsensusProtocol(..) , ChainSelection(..) + , HasChainIndepState(..) , ConsensusConfig -- * LeaderCheck , LeaderCheck(..) @@ -22,10 +23,11 @@ import GHC.Stack import Cardano.Prelude (NoUnexpectedThunks) -import Ouroboros.Network.Block (BlockNo, HeaderHash, Point) +import Ouroboros.Network.Block (BlockNo, HeaderHash, Point, SlotNo) import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Ledger.Abstract (Ticked) +import Ouroboros.Consensus.Util.IOLike -- | Static configuration required to run the consensus protocol -- @@ -102,27 +104,69 @@ class ( NoUnexpectedThunks (ChainSelConfig p) -> Ordering compareCandidates _ _ = compare +-- | Chain independent state +class ( Show (ChainIndepState p) + , NoUnexpectedThunks (ChainIndepState p) + , NoUnexpectedThunks (ChainIndepStateConfig p) + ) => HasChainIndepState p where + + -- | Configuration required for dealing with chain independent state. + type family ChainIndepStateConfig p :: * + type ChainIndepStateConfig p = () + + -- | Blockchain independent state. + -- + -- For example, it can store a key that needs to be evolved over time. + type family ChainIndepState p :: * + type ChainIndepState p = () + + -- | Update the chain independent state for the current wallclock 'SlotNo'. + -- + -- NOTE: Although this only happens (just before) we do the 'checkIsLeader' + -- check, we do not pass a 'LedgerView'. From a philosophical point of view, + -- passing a 'LedgerView' does not make much sense, since we are updating + -- the chain /independent/ state. From a pragmatic, and perhaps more + -- important, point of view, passing a 'LedgerView' here would make the hard + -- fork combinator impossible: the HFC needs to update the 'ChainIndepState' + -- for all eras, but we’d only have a 'LedgerView' for a single era. + updateChainIndepState :: IOLike m + => proxy p + -> ChainIndepStateConfig p + -> SlotNo + -> ChainIndepState p + -> m (ChainIndepState p) + default updateChainIndepState :: + (ChainIndepState p ~ (), Monad m) + => proxy p + -> ChainIndepStateConfig p + -> SlotNo + -> ChainIndepState p + -> m (ChainIndepState p) + updateChainIndepState _ _ _ = return + -- | The (open) universe of Ouroboros protocols -- -- This class encodes the part that is independent from any particular -- block representation. -class ( Show (ConsensusState p) - , Show (ValidationErr p) - , Show (LedgerView p) - , Show (CannotLead p) - , Eq (ConsensusState p) - , Eq (ValidationErr p) +class ( Show (ChainDepState p) + , Show (ChainIndepState p) + , Show (ValidationErr p) + , Show (LedgerView p) + , Show (CannotLead p) + , Eq (ChainDepState p) + , Eq (ValidationErr p) , NoUnexpectedThunks (ConsensusConfig p) - , NoUnexpectedThunks (ConsensusState p) + , NoUnexpectedThunks (ChainDepState p) , NoUnexpectedThunks (ValidationErr p) , Typeable p -- so that p can appear in exceptions , ChainSelection p + , HasChainIndepState p ) => ConsensusProtocol p where -- | Protocol-specific state -- -- NOTE: This chain is blockchain dependent, i.e., updated when new blocks -- come in (more precisely, new /headers/), and subject to rollback. - type family ConsensusState p :: * + type family ChainDepState p :: * -- | Evidence that a node /is/ the leader type family IsLeader p :: * @@ -194,16 +238,17 @@ class ( Show (ConsensusState p) => ConsensusConfig p -> CanBeLeader p -> Ticked (LedgerView p) - -> ConsensusState p + -> ChainIndepState p + -> ChainDepState p -> m (LeaderCheck p) -- | Apply a header - updateConsensusState :: HasCallStack - => ConsensusConfig p - -> Ticked (LedgerView p) - -> ValidateView p - -> ConsensusState p - -> Except (ValidationErr p) (ConsensusState p) + updateChainDepState :: HasCallStack + => ConsensusConfig p + -> Ticked (LedgerView p) + -> ValidateView p + -> ChainDepState p + -> Except (ValidationErr p) (ChainDepState p) -- | We require that protocols support a @k@ security parameter protocolSecurityParam :: ConsensusConfig p -> SecurityParam @@ -216,12 +261,12 @@ class ( Show (ConsensusState p) -- -- PRECONDITION: the point to rewind to must correspond to a header (or -- 'GenesisPoint') that was previously applied to the chain state using - -- 'updateConsensusState'. + -- 'updateChainDepState'. -- -- 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 'updateConsensusState') at least as many blocks that we have + -- forward (using 'updateChainDepState') at least as many blocks that we have -- rewound. -- -- Note that repeatedly rewinding a chain state does not make it possible to @@ -233,11 +278,11 @@ class ( Show (ConsensusState p) -- -- TODO: The Serialise instance is only required for a hack in PBFT. -- Reconsider later. - rewindConsensusState :: Serialise (HeaderHash hdr) - => proxy p - -> SecurityParam - -> Point hdr -- ^ Point to rewind to - -> ConsensusState p -> Maybe (ConsensusState p) + rewindChainDepState :: Serialise (HeaderHash hdr) + => proxy p + -> SecurityParam + -> Point hdr -- ^ Point to rewind to + -> ChainDepState p -> Maybe (ChainDepState p) {------------------------------------------------------------------------------- Result of 'checkIsLeader' diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs index 44af5906648..9e2fdedd8f0 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs @@ -124,21 +124,24 @@ data instance ConsensusConfig (Bft c) = BftConfig { } deriving (Generic) -instance BftCrypto c => ChainSelection (Bft c) where +instance ChainSelection (Bft c) + -- Use defaults + +instance HasChainIndepState (Bft c) -- Use defaults instance BftCrypto c => ConsensusProtocol (Bft c) where - type ValidationErr (Bft c) = BftValidationErr - type ValidateView (Bft c) = BftValidateView c - type LedgerView (Bft c) = () - type IsLeader (Bft c) = () - type ConsensusState (Bft c) = () - type CanBeLeader (Bft c) = CoreNodeId - type CannotLead (Bft c) = Void + type ValidationErr (Bft c) = BftValidationErr + type ValidateView (Bft c) = BftValidateView c + type LedgerView (Bft c) = () + type IsLeader (Bft c) = () + type ChainDepState (Bft c) = () + type CanBeLeader (Bft c) = CoreNodeId + type CannotLead (Bft c) = Void protocolSecurityParam = bftSecurityParam . bftParams - checkIsLeader BftConfig{..} (CoreNodeId i) (Ticked (SlotNo n) _l) _cs = do + checkIsLeader BftConfig{..} (CoreNodeId i) (Ticked (SlotNo n) _l) _cis _cds = do return $ if n `mod` numCoreNodes == i then IsLeader () else NotLeader @@ -146,10 +149,10 @@ instance BftCrypto c => ConsensusProtocol (Bft c) where BftParams{..} = bftParams NumCoreNodes numCoreNodes = bftNumNodes - updateConsensusState BftConfig{..} - _l - (BftValidateView (SlotNo n) BftFields{..} signed) - _cs = + updateChainDepState BftConfig{..} + _l + (BftValidateView (SlotNo n) BftFields{..} signed) + _cs = -- TODO: Should deal with unknown node IDs case verifySignedDSIGN () @@ -163,7 +166,7 @@ instance BftCrypto c => ConsensusProtocol (Bft c) where expectedLeader = CoreId $ CoreNodeId (n `mod` numCoreNodes) NumCoreNodes numCoreNodes = bftNumNodes - rewindConsensusState _ _ _ _ = Just () + rewindChainDepState _ _ _ _ = Just () instance BftCrypto c => NoUnexpectedThunks (ConsensusConfig (Bft c)) -- use generic instance diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs index 35d515d94b2..da4e0fd3e4b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs @@ -81,6 +81,9 @@ instance ChainSelection p => ChainSelection (WithLeaderSchedule p) where preferCandidate _ = preferCandidate (Proxy @p) compareCandidates _ = compareCandidates (Proxy @p) +instance HasChainIndepState p => HasChainIndepState (WithLeaderSchedule p) where + -- Don't forward to @p@, but use the defaults + data instance ConsensusConfig (WithLeaderSchedule p) = WLSConfig { wlsConfigSchedule :: !LeaderSchedule , wlsConfigP :: !(ConsensusConfig p) @@ -89,26 +92,26 @@ data instance ConsensusConfig (WithLeaderSchedule p) = WLSConfig deriving (Generic) instance ConsensusProtocol p => ConsensusProtocol (WithLeaderSchedule p) where - type ConsensusState (WithLeaderSchedule p) = () - type LedgerView (WithLeaderSchedule p) = () - type ValidationErr (WithLeaderSchedule p) = () - type IsLeader (WithLeaderSchedule p) = () - type ValidateView (WithLeaderSchedule p) = () - type CanBeLeader (WithLeaderSchedule p) = () - type CannotLead (WithLeaderSchedule p) = Void + type ChainDepState (WithLeaderSchedule p) = () + type LedgerView (WithLeaderSchedule p) = () + type ValidationErr (WithLeaderSchedule p) = () + type IsLeader (WithLeaderSchedule p) = () + type ValidateView (WithLeaderSchedule p) = () + type CanBeLeader (WithLeaderSchedule p) = () + type CannotLead (WithLeaderSchedule p) = Void protocolSecurityParam = protocolSecurityParam . wlsConfigP chainSelConfig = chainSelConfig . wlsConfigP - checkIsLeader WLSConfig{..} () (Ticked slot _) _ = return $ + checkIsLeader WLSConfig{..} () (Ticked slot _) _ _ = return $ case Map.lookup slot $ getLeaderSchedule wlsConfigSchedule of Nothing -> error $ "WithLeaderSchedule: missing slot " ++ show slot Just nids | wlsConfigNodeId `elem` nids -> IsLeader () | otherwise -> NotLeader - updateConsensusState _ _ _ _ = return () - rewindConsensusState _ _ _ _ = Just () + updateChainDepState _ _ _ _ = return () + rewindChainDepState _ _ _ _ = Just () instance ConsensusProtocol p => NoUnexpectedThunks (ConsensusConfig (WithLeaderSchedule p)) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs index 308f065373b..84fe09c1c04 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs @@ -39,24 +39,35 @@ instance ChainSelection s => ChainSelection (ModChainSel p s) where preferCandidate _ = preferCandidate (Proxy @s) compareCandidates _ = compareCandidates (Proxy @s) +instance HasChainIndepState p => HasChainIndepState (ModChainSel p s) where + type ChainIndepStateConfig (ModChainSel p s) = ChainIndepStateConfig p + type ChainIndepState (ModChainSel p s) = ChainIndepState p + + updateChainIndepState _proxy = updateChainIndepState (Proxy @p) + instance (Typeable p, Typeable s, ConsensusProtocol p, ChainSelection s) => ConsensusProtocol (ModChainSel p s) where - type ConsensusState (ModChainSel p s) = ConsensusState p - type IsLeader (ModChainSel p s) = IsLeader p - type CanBeLeader (ModChainSel p s) = CanBeLeader p - type CannotLead (ModChainSel p s) = CannotLead p - type LedgerView (ModChainSel p s) = LedgerView p - type ValidationErr (ModChainSel p s) = ValidationErr p - type ValidateView (ModChainSel p s) = ValidateView p - - checkIsLeader cfg canBeLeader ledgerView consensusState = + type ChainDepState (ModChainSel p s) = ChainDepState p + type IsLeader (ModChainSel p s) = IsLeader p + type CanBeLeader (ModChainSel p s) = CanBeLeader p + type CannotLead (ModChainSel p s) = CannotLead p + type LedgerView (ModChainSel p s) = LedgerView p + type ValidationErr (ModChainSel p s) = ValidationErr p + type ValidateView (ModChainSel p s) = ValidateView p + + checkIsLeader cfg canBeLeader ledgerView chainDepState chainIndepState = castLeaderCheck <$> - checkIsLeader (mcsConfigP cfg) canBeLeader ledgerView consensusState + checkIsLeader + (mcsConfigP cfg) + canBeLeader + ledgerView + chainDepState + chainIndepState - updateConsensusState = updateConsensusState . mcsConfigP + updateChainDepState = updateChainDepState . mcsConfigP protocolSecurityParam = protocolSecurityParam . mcsConfigP - rewindConsensusState _proxy = rewindConsensusState (Proxy @p) + rewindChainDepState _proxy = rewindChainDepState (Proxy @p) chainSelConfig = mcsConfigS diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index 4be7c653f98..5b5b09a875b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -271,6 +271,9 @@ instance PBftCrypto c => ChainSelection (PBft c) where score IsEBB = 1 score IsNotEBB = 0 +instance HasChainIndepState (PBft c) + -- Use defaults + instance PBftCrypto c => ConsensusProtocol (PBft c) where type ValidationErr (PBft c) = PBftValidationErr c type ValidateView (PBft c) = PBftValidateView c @@ -279,18 +282,18 @@ instance PBftCrypto c => ConsensusProtocol (PBft c) where -- -- - Protocol parameters, for the signature window and threshold. -- - The delegation map. - type LedgerView (PBft c) = PBftLedgerView c - type IsLeader (PBft c) = PBftIsLeader c - type ConsensusState (PBft c) = PBftState c - type CanBeLeader (PBft c) = PBftIsLeader c - type CannotLead (PBft c) = PBftCannotLead c + type LedgerView (PBft c) = PBftLedgerView c + type IsLeader (PBft c) = PBftIsLeader c + type ChainDepState (PBft c) = PBftState c + type CanBeLeader (PBft c) = PBftIsLeader c + type CannotLead (PBft c) = PBftCannotLead c protocolSecurityParam = pbftSecurityParam . pbftParams checkIsLeader cfg@PBftConfig{pbftParams} credentials - (Ticked slot@(SlotNo n) (PBftLedgerView dms)) cs = + (Ticked slot@(SlotNo n) (PBftLedgerView dms)) _cis cds = -- We are the slot leader based on our node index, and the current -- slot number. Our node index depends which genesis key has delegated -- to us, see 'genesisKeyCoreNodeId'. @@ -299,7 +302,7 @@ instance PBftCrypto c => ConsensusProtocol (PBft c) where then case Bimap.lookupR dlgKeyHash dms of Nothing -> CannotLead $ PBftCannotLeadInvalidDelegation dlgKeyHash Just gk -> do - let state' = append cfg params (slot, gk) cs + let state' = append cfg params (slot, gk) cds case exceedsThreshold params state' gk of Nothing -> IsLeader credentials Just numForged -> CannotLead $ PBftCannotLeadThresholdExceeded numForged @@ -310,7 +313,7 @@ instance PBftCrypto c => ConsensusProtocol (PBft c) where PBftIsLeader{pbftCoreNodeId = CoreNodeId i, pbftDlgCert} = credentials PBftParams{pbftNumNodes = NumCoreNodes numCoreNodes} = pbftParams - updateConsensusState cfg@PBftConfig{..} (Ticked _ lv@(PBftLedgerView dms)) toValidate state = + updateChainDepState cfg@PBftConfig{..} (Ticked _ lv@(PBftLedgerView dms)) toValidate state = case toValidate of PBftValidateBoundary slot hash -> return $! appendEBB cfg params slot hash state @@ -341,7 +344,7 @@ instance PBftCrypto c => ConsensusProtocol (PBft c) where where params = pbftWindowParams cfg - rewindConsensusState _proxy = rewind + rewindChainDepState _proxy = rewind {------------------------------------------------------------------------------- Internal: thin wrapper on top of 'PBftState' diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/State.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/State.hs index 2a949db5cbc..20808c25f03 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/State.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/State.hs @@ -408,7 +408,7 @@ append k n signer@(PBftSigner _ gk) PBftState{..} = -- | Rewind the state to the specified slot -- --- This matches the semantics of 'rewindConsensusState' in 'OuroborosTag', in +-- This matches the semantics of 'rewindchainDepState' in 'OuroborosTag', in -- that this should be the state after the given point. -- -- NOTE: It only makes sense to rewind to a slot containing a block that we @@ -677,10 +677,10 @@ data MaybeEbbInfo -- | Info about an EBB -- --- The serialised bytes of the EBB's header hash and its latest previous signed --- slot. We use 'HeaderHashBytes' instead of the EBB's actual @HeaderHash@ --- because the 'ConsensusState' type family (which we instantiate as --- 'PBftState') does not take a type argument that to which we can apply +-- The serialised bytes of the EBB's header hash and its latest previous +-- signed slot. We use 'HeaderHashBytes' instead of the EBB's actual +-- @HeaderHash@ because the 'ChainDepState' type family (which we instantiate +-- as 'PBftState') does not take a type argument that to which we can apply -- @HeaderHash@. This is a compromise. -- -- INVARIANT @At 'eiSlot' > 'eiPrevSlot'@ diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs index 79e4ce933b6..6288f7c4896 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs @@ -144,8 +144,8 @@ class ( -- TODO remove/replace this one once we remove it from the , DecodeDisk blk (LedgerState blk) , EncodeDisk blk (AnnTip blk) , DecodeDisk blk (AnnTip blk) - , EncodeDisk blk (ConsensusState (BlockProtocol blk)) - , DecodeDisk blk (ConsensusState (BlockProtocol blk)) + , EncodeDisk blk (ChainDepState (BlockProtocol blk)) + , DecodeDisk blk (ChainDepState (BlockProtocol blk)) ) => LgrDbSerialiseConstraints blk -- | Shorter synonym for the instantiated 'LedgerDB.LedgerDB'. diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Serialisation.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Serialisation.hs index 764e5fc6dda..2d06eec8bcf 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Serialisation.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Serialisation.hs @@ -332,13 +332,13 @@ takePrefix (PrefixLen n) = Forwarding instances -------------------------------------------------------------------------------} -instance EncodeDisk blk (ConsensusState (BlockProtocol blk)) - => EncodeDisk blk (WrapConsensusState blk) where - encodeDisk cfg (WrapConsensusState st) = encodeDisk cfg st +instance EncodeDisk blk (ChainDepState (BlockProtocol blk)) + => EncodeDisk blk (WrapChainDepState blk) where + encodeDisk cfg (WrapChainDepState st) = encodeDisk cfg st -instance DecodeDisk blk (ConsensusState (BlockProtocol blk)) - => DecodeDisk blk (WrapConsensusState blk) where - decodeDisk cfg = WrapConsensusState <$> decodeDisk cfg +instance DecodeDisk blk (ChainDepState (BlockProtocol blk)) + => DecodeDisk blk (WrapChainDepState blk) where + decodeDisk cfg = WrapChainDepState <$> decodeDisk cfg instance EncodeDisk blk blk => EncodeDisk blk (I blk) where diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/TypeFamilyWrappers.hs b/ouroboros-consensus/src/Ouroboros/Consensus/TypeFamilyWrappers.hs index 11efda13ed6..792c8d08448 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/TypeFamilyWrappers.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/TypeFamilyWrappers.hs @@ -8,7 +8,7 @@ module Ouroboros.Consensus.TypeFamilyWrappers ( -- * Block based WrapApplyTxErr(..) , WrapEnvelopeErr(..) - , WrapForgeState(..) + , WrapExtraForgeState(..) , WrapGenTxId(..) , WrapHeaderHash(..) , WrapLedgerConfig(..) @@ -19,7 +19,9 @@ module Ouroboros.Consensus.TypeFamilyWrappers ( , WrapCannotLead(..) , WrapChainSelConfig(..) , WrapConsensusConfig(..) - , WrapConsensusState(..) + , WrapChainDepState(..) + , WrapChainIndepState(..) + , WrapChainIndepStateConfig(..) , WrapIsLeader(..) , WrapLeaderCheck(..) , WrapLedgerView(..) @@ -43,35 +45,38 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Util (Trivial (..)) {------------------------------------------------------------------------------- Block based -------------------------------------------------------------------------------} -newtype WrapApplyTxErr blk = WrapApplyTxErr { unwrapApplyTxErr :: ApplyTxErr blk } -newtype WrapEnvelopeErr blk = WrapEnvelopeErr { unwrapEnvelopeErr :: OtherHeaderEnvelopeError blk } -newtype WrapForgeState blk = WrapForgeState { unwrapForgeState :: ForgeState blk } -newtype WrapGenTxId blk = WrapGenTxId { unwrapGenTxId :: GenTxId blk } -newtype WrapHeaderHash blk = WrapHeaderHash { unwrapHeaderHash :: HeaderHash blk } -newtype WrapLedgerConfig blk = WrapLedgerConfig { unwrapLedgerConfig :: LedgerConfig blk } -newtype WrapLedgerErr blk = WrapLedgerErr { unwrapLedgerErr :: LedgerError blk } -newtype WrapTipInfo blk = WrapTipInfo { unwrapTipInfo :: TipInfo blk } +newtype WrapApplyTxErr blk = WrapApplyTxErr { unwrapApplyTxErr :: ApplyTxErr blk } +newtype WrapEnvelopeErr blk = WrapEnvelopeErr { unwrapEnvelopeErr :: OtherHeaderEnvelopeError blk } +newtype WrapExtraForgeState blk = WrapExtraForgeState { unwrapExtraForgeState :: ExtraForgeState blk } +newtype WrapGenTxId blk = WrapGenTxId { unwrapGenTxId :: GenTxId blk } +newtype WrapHeaderHash blk = WrapHeaderHash { unwrapHeaderHash :: HeaderHash blk } +newtype WrapLedgerConfig blk = WrapLedgerConfig { unwrapLedgerConfig :: LedgerConfig blk } +newtype WrapLedgerErr blk = WrapLedgerErr { unwrapLedgerErr :: LedgerError blk } +newtype WrapTipInfo blk = WrapTipInfo { unwrapTipInfo :: TipInfo blk } {------------------------------------------------------------------------------- Consensus based -------------------------------------------------------------------------------} -newtype WrapCanBeLeader blk = WrapCanBeLeader { unwrapCanBeLeader :: CanBeLeader (BlockProtocol blk) } -newtype WrapCannotLead blk = WrapCannotLead { unwrapCannotLead :: CannotLead (BlockProtocol blk) } -newtype WrapChainSelConfig blk = WrapChainSelConfig { unwrapChainSelConfig :: ChainSelConfig (BlockProtocol blk) } -newtype WrapConsensusConfig blk = WrapConsensusConfig { unwrapConsensusConfig :: ConsensusConfig (BlockProtocol blk) } -newtype WrapConsensusState blk = WrapConsensusState { unwrapConsensusState :: ConsensusState (BlockProtocol blk) } -newtype WrapIsLeader blk = WrapIsLeader { unwrapIsLeader :: IsLeader (BlockProtocol blk) } -newtype WrapLeaderCheck blk = WrapLeaderCheck { unwrapLeaderCheck :: LeaderCheck (BlockProtocol blk) } -newtype WrapLedgerView blk = WrapLedgerView { unwrapLedgerView :: LedgerView (BlockProtocol blk) } -newtype WrapSelectView blk = WrapSelectView { unwrapSelectView :: SelectView (BlockProtocol blk) } -newtype WrapValidateView blk = WrapValidateView { unwrapValidateView :: ValidateView (BlockProtocol blk) } -newtype WrapValidationErr blk = WrapValidationErr { unwrapValidationErr :: ValidationErr (BlockProtocol blk) } +newtype WrapCanBeLeader blk = WrapCanBeLeader { unwrapCanBeLeader :: CanBeLeader (BlockProtocol blk) } +newtype WrapCannotLead blk = WrapCannotLead { unwrapCannotLead :: CannotLead (BlockProtocol blk) } +newtype WrapChainSelConfig blk = WrapChainSelConfig { unwrapChainSelConfig :: ChainSelConfig (BlockProtocol blk) } +newtype WrapConsensusConfig blk = WrapConsensusConfig { unwrapConsensusConfig :: ConsensusConfig (BlockProtocol blk) } +newtype WrapChainDepState blk = WrapChainDepState { unwrapChainDepState :: ChainDepState (BlockProtocol blk) } +newtype WrapChainIndepState blk = WrapChainIndepState { unwrapChainIndepState :: ChainIndepState (BlockProtocol blk) } +newtype WrapChainIndepStateConfig blk = WrapChainIndepStateConfig { unwrapChainIndepStateConfig :: ChainIndepStateConfig (BlockProtocol blk) } +newtype WrapIsLeader blk = WrapIsLeader { unwrapIsLeader :: IsLeader (BlockProtocol blk) } +newtype WrapLeaderCheck blk = WrapLeaderCheck { unwrapLeaderCheck :: LeaderCheck (BlockProtocol blk) } +newtype WrapLedgerView blk = WrapLedgerView { unwrapLedgerView :: LedgerView (BlockProtocol blk) } +newtype WrapSelectView blk = WrapSelectView { unwrapSelectView :: SelectView (BlockProtocol blk) } +newtype WrapValidateView blk = WrapValidateView { unwrapValidateView :: ValidateView (BlockProtocol blk) } +newtype WrapValidationErr blk = WrapValidationErr { unwrapValidationErr :: ValidationErr (BlockProtocol blk) } {------------------------------------------------------------------------------- Versioning @@ -92,35 +97,42 @@ deriving instance Eq (TipInfo blk) => Eq (WrapTipInfo blk) deriving instance Ord (GenTxId blk) => Ord (WrapGenTxId blk) -deriving instance Show (ApplyTxErr blk) => Show (WrapApplyTxErr blk) -deriving instance Show (ForgeState blk) => Show (WrapForgeState blk) -deriving instance Show (GenTxId blk) => Show (WrapGenTxId blk) -deriving instance Show (LedgerError blk) => Show (WrapLedgerErr blk) -deriving instance Show (OtherHeaderEnvelopeError blk) => Show (WrapEnvelopeErr blk) -deriving instance Show (TipInfo blk) => Show (WrapTipInfo blk) +deriving instance Show (ApplyTxErr blk) => Show (WrapApplyTxErr blk) +deriving instance Show (ExtraForgeState blk) => Show (WrapExtraForgeState blk) +deriving instance Show (GenTxId blk) => Show (WrapGenTxId blk) +deriving instance Show (LedgerError blk) => Show (WrapLedgerErr blk) +deriving instance Show (OtherHeaderEnvelopeError blk) => Show (WrapEnvelopeErr blk) +deriving instance Show (TipInfo blk) => Show (WrapTipInfo blk) -deriving instance NoUnexpectedThunks (ForgeState blk) => NoUnexpectedThunks (WrapForgeState blk) -deriving instance NoUnexpectedThunks (GenTxId blk) => NoUnexpectedThunks (WrapGenTxId blk) -deriving instance NoUnexpectedThunks (LedgerError blk) => NoUnexpectedThunks (WrapLedgerErr blk) -deriving instance NoUnexpectedThunks (OtherHeaderEnvelopeError blk) => NoUnexpectedThunks (WrapEnvelopeErr blk) -deriving instance NoUnexpectedThunks (TipInfo blk) => NoUnexpectedThunks (WrapTipInfo blk) +deriving instance NoUnexpectedThunks (ExtraForgeState blk) => NoUnexpectedThunks (WrapExtraForgeState blk) +deriving instance NoUnexpectedThunks (GenTxId blk) => NoUnexpectedThunks (WrapGenTxId blk) +deriving instance NoUnexpectedThunks (LedgerError blk) => NoUnexpectedThunks (WrapLedgerErr blk) +deriving instance NoUnexpectedThunks (OtherHeaderEnvelopeError blk) => NoUnexpectedThunks (WrapEnvelopeErr blk) +deriving instance NoUnexpectedThunks (TipInfo blk) => NoUnexpectedThunks (WrapTipInfo blk) + +deriving instance Trivial (ExtraForgeState blk) => Trivial (WrapExtraForgeState blk) {------------------------------------------------------------------------------- .. consensus based -------------------------------------------------------------------------------} -deriving instance Eq (ConsensusState (BlockProtocol blk)) => Eq (WrapConsensusState blk) +deriving instance Eq (ChainDepState (BlockProtocol blk)) => Eq (WrapChainDepState blk) deriving instance Eq (ValidationErr (BlockProtocol blk)) => Eq (WrapValidationErr blk) -deriving instance Show (CannotLead (BlockProtocol blk)) => Show (WrapCannotLead blk) -deriving instance Show (ConsensusState (BlockProtocol blk)) => Show (WrapConsensusState blk) -deriving instance Show (LedgerView (BlockProtocol blk)) => Show (WrapLedgerView blk) -deriving instance Show (SelectView (BlockProtocol blk)) => Show (WrapSelectView blk) -deriving instance Show (ValidationErr (BlockProtocol blk)) => Show (WrapValidationErr blk) +deriving instance Show (CannotLead (BlockProtocol blk)) => Show (WrapCannotLead blk) +deriving instance Show (ChainDepState (BlockProtocol blk)) => Show (WrapChainDepState blk) +deriving instance Show (ChainIndepState (BlockProtocol blk)) => Show (WrapChainIndepState blk) +deriving instance Show (LedgerView (BlockProtocol blk)) => Show (WrapLedgerView blk) +deriving instance Show (SelectView (BlockProtocol blk)) => Show (WrapSelectView blk) +deriving instance Show (ValidationErr (BlockProtocol blk)) => Show (WrapValidationErr blk) + +deriving instance NoUnexpectedThunks (ChainSelConfig (BlockProtocol blk)) => NoUnexpectedThunks (WrapChainSelConfig blk) +deriving instance NoUnexpectedThunks (ChainDepState (BlockProtocol blk)) => NoUnexpectedThunks (WrapChainDepState blk) +deriving instance NoUnexpectedThunks (ChainIndepState (BlockProtocol blk)) => NoUnexpectedThunks (WrapChainIndepState blk) +deriving instance NoUnexpectedThunks (ChainIndepStateConfig (BlockProtocol blk)) => NoUnexpectedThunks (WrapChainIndepStateConfig blk) +deriving instance NoUnexpectedThunks (ValidationErr (BlockProtocol blk)) => NoUnexpectedThunks (WrapValidationErr blk) -deriving instance NoUnexpectedThunks (ChainSelConfig (BlockProtocol blk)) => NoUnexpectedThunks (WrapChainSelConfig blk) -deriving instance NoUnexpectedThunks (ConsensusState (BlockProtocol blk)) => NoUnexpectedThunks (WrapConsensusState blk) -deriving instance NoUnexpectedThunks (ValidationErr (BlockProtocol blk)) => NoUnexpectedThunks (WrapValidationErr blk) +deriving instance Trivial (ChainIndepState (BlockProtocol blk)) => Trivial (WrapChainIndepState blk) {------------------------------------------------------------------------------- Versioning @@ -139,5 +151,5 @@ deriving instance Eq (BlockNodeToClientVersion blk) => Eq (WrapNodeToClientVersi -------------------------------------------------------------------------------} deriving instance Serialise (GenTxId blk) => Serialise (WrapGenTxId blk) -deriving instance Serialise (ConsensusState (BlockProtocol blk)) => Serialise (WrapConsensusState blk) +deriving instance Serialise (ChainDepState (BlockProtocol blk)) => Serialise (WrapChainDepState blk) deriving instance Serialise (TipInfo blk) => Serialise (WrapTipInfo blk) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs index 8abdfba97af..434c7bd1211 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | Miscellaneous utilities module Ouroboros.Consensus.Util ( @@ -49,6 +53,8 @@ module Ouroboros.Consensus.Util ( , (....:) -- * Miscellaneous , fib + -- * Trivial + , Trivial(..) ) where import qualified Data.ByteString as Strict @@ -60,6 +66,7 @@ import Data.Kind import Data.List (foldl', maximumBy) import Data.Set (Set) import qualified Data.Set as Set +import Data.SOP.Strict import Data.Void import Data.Word (Word64) import GHC.Stack @@ -255,3 +262,21 @@ fib n = round $ phi ** fromIntegral n / sq5 sq5, phi :: Double sq5 = sqrt 5 phi = (1 + sq5) / 2 + +{------------------------------------------------------------------------------- + Trivial +-------------------------------------------------------------------------------} + +-- | Trivial values of the same type should all be equal: +-- > forall (x :: a), x == trivial (Proxy @a) +class Trivial a where + trivial :: Proxy a -> a + +instance Trivial () where + trivial _ = () + +instance All (Trivial `Compose` f) xs => Trivial (NP f xs) where + trivial _ = hcpure (Proxy @(Trivial `Compose` f)) trivialOne + where + trivialOne :: forall a. (Trivial `Compose` f) a => f a + trivialOne = trivial (Proxy @(f a)) diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator.hs index 250c9db05f6..2eeb17282b8 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator.hs @@ -238,18 +238,13 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = initLedgerState , headerState = genesisHeaderState $ initHardForkState - (WrapConsensusState initConsensusState) + (WrapChainDepState initChainDepState) } , pInfoLeaderCreds = Just ( OptCons (WrapCanBeLeader ()) $ OptCons (WrapCanBeLeader ()) $ OptNil - , MaintainForgeState { - initForgeState = PerEraForgeState $ WrapForgeState () - :* WrapForgeState () - :* Nil - , updateForgeState = \_ _ -> return () - } + , defaultMaintainForgeState ) } @@ -259,8 +254,8 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = , lgrA_transition = Nothing } - initConsensusState :: ConsensusState ProtocolA - initConsensusState = () + initChainDepState :: ChainDepState ProtocolA + initChainDepState = () topLevelConfig :: CoreNodeId -> TopLevelConfig TestBlock topLevelConfig nid = TopLevelConfig { @@ -272,6 +267,10 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = :* (WrapPartialConsensusConfig $ consensusConfigB nid) :* Nil } + , configIndep = PerEraChainIndepStateConfig $ + (WrapChainIndepStateConfig ()) + :* (WrapChainIndepStateConfig ()) + :* Nil , configLedger = HardForkLedgerConfig { hardForkLedgerConfigK = k , hardForkLedgerConfigShape = shape @@ -368,9 +367,9 @@ type TestBlock = HardForkBlock '[BlockA, BlockB] instance CanHardFork '[BlockA, BlockB] where hardForkEraTranslation = EraTranslation { - translateLedgerState = PCons ledgerState_AtoB PNil - , translateLedgerView = PCons ledgerView_AtoB PNil - , translateConsensusState = PCons consensusState_AtoB PNil + translateLedgerState = PCons ledgerState_AtoB PNil + , translateLedgerView = PCons ledgerView_AtoB PNil + , translateChainDepState = PCons chainDepState_AtoB PNil } versionN2N :: BlockNodeToNodeVersion TestBlock @@ -422,5 +421,5 @@ ledgerState_AtoB = RequireBoth $ \_ _ -> Translate $ \_ LgrA{..} -> LgrB { ledgerView_AtoB :: RequiringBoth WrapLedgerConfig (Translate WrapLedgerView) BlockA BlockB ledgerView_AtoB = RequireBoth $ \_ _ -> Translate $ \_ _ -> WrapLedgerView () -consensusState_AtoB :: RequiringBoth WrapConsensusConfig (Translate WrapConsensusState) BlockA BlockB -consensusState_AtoB = RequireBoth $ \_ _ -> Translate $ \_ _ -> WrapConsensusState () +chainDepState_AtoB :: RequiringBoth WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB +chainDepState_AtoB = RequireBoth $ \_ _ -> Translate $ \_ _ -> WrapChainDepState () diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs index 19ee0303636..981a340ab61 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs @@ -102,23 +102,26 @@ data instance ConsensusConfig ProtocolA = CfgA { instance ChainSelection ProtocolA where -- Use defaults +instance HasChainIndepState ProtocolA where + -- Use defaults + instance ConsensusProtocol ProtocolA where - type ConsensusState ProtocolA = () - type LedgerView ProtocolA = () - type IsLeader ProtocolA = () - type CanBeLeader ProtocolA = () - type CannotLead ProtocolA = Void - type ValidateView ProtocolA = () - type ValidationErr ProtocolA = Void - - checkIsLeader CfgA{..} () (Ticked slot _) _ = + type ChainDepState ProtocolA = () + type LedgerView ProtocolA = () + type IsLeader ProtocolA = () + type CanBeLeader ProtocolA = () + type CannotLead ProtocolA = Void + type ValidateView ProtocolA = () + type ValidationErr ProtocolA = Void + + checkIsLeader CfgA{..} () (Ticked slot _) _ _ = return $ if slot `Set.member` cfgA_leadInSlots then IsLeader () else NotLeader protocolSecurityParam = cfgA_k - updateConsensusState = \_ _ _ _ -> return () - rewindConsensusState = \_ _ _ _ -> Just () + updateChainDepState = \_ _ _ _ -> return () + rewindChainDepState = \_ _ _ _ -> Just () data BlockA = BlkA { blkA_header :: Header BlockA @@ -241,7 +244,7 @@ instance CommonProtocolParams BlockA where maxTxSize _ = maxBound instance CanForge BlockA where - forgeBlock TopLevelConfig{..} _ bno (Ticked sno st) _txs _ = return $ BlkA { + forgeBlock TopLevelConfig{..} _ bno (Ticked sno st) _txs _ = BlkA { blkA_header = HdrA { hdrA_fields = HeaderFields { headerFieldHash = Lazy.toStrict . B.encode $ unSlotNo sno diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs index 4e7d9244b41..d3b1d4071bc 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs @@ -89,23 +89,26 @@ data instance ConsensusConfig ProtocolB = CfgB { instance ChainSelection ProtocolB where -- Use defaults +instance HasChainIndepState ProtocolB where + -- Use defaults + instance ConsensusProtocol ProtocolB where - type ConsensusState ProtocolB = () - type LedgerView ProtocolB = () - type IsLeader ProtocolB = () - type CanBeLeader ProtocolB = () - type CannotLead ProtocolB = Void - type ValidateView ProtocolB = () - type ValidationErr ProtocolB = Void - - checkIsLeader CfgB{..} () (Ticked slot _) _ = + type ChainDepState ProtocolB = () + type LedgerView ProtocolB = () + type IsLeader ProtocolB = () + type CanBeLeader ProtocolB = () + type CannotLead ProtocolB = Void + type ValidateView ProtocolB = () + type ValidationErr ProtocolB = Void + + checkIsLeader CfgB{..} () (Ticked slot _) _ _ = return $ if slot `Set.member` cfgB_leadInSlots then IsLeader () else NotLeader protocolSecurityParam = cfgB_k - updateConsensusState = \_ _ _ _ -> return () - rewindConsensusState = \_ _ _ _ -> Just () + updateChainDepState = \_ _ _ _ -> return () + rewindChainDepState = \_ _ _ _ -> Just () data BlockB = BlkB { blkB_header :: Header BlockB @@ -199,7 +202,7 @@ instance CommonProtocolParams BlockB where maxTxSize _ = maxBound instance CanForge BlockB where - forgeBlock _ _ bno (Ticked sno st) _txs _ = return $ BlkB { + forgeBlock _ _ bno (Ticked sno st) _txs _ = BlkB { blkB_header = HdrB { hdrB_fields = HeaderFields { headerFieldHash = Lazy.toStrict . B.encode $ unSlotNo sno diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test-consensus/Test/Consensus/MiniProtocol/ChainSync/Client.hs index bce749ba61d..51be647bf66 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/MiniProtocol/ChainSync/Client.hs @@ -397,6 +397,7 @@ runChainSync securityParam (ClientUpdates clientUpdates) , (CoreId (CoreNodeId 1), VerKeyMockDSIGN 1) ] } + , configIndep = () , configLedger = eraParams , configBlock = TestBlockConfig numCoreNodes } diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index db22e23afbf..e21c003b46e 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -224,6 +224,7 @@ testCfg securityParam = TopLevelConfig { , bftSignKey = SignKeyMockDSIGN 0 , bftVerKeys = Map.singleton (CoreId (CoreNodeId 0)) (VerKeyMockDSIGN 0) } + , configIndep = () , configLedger = eraParams , configBlock = TestBlockConfig numCoreNodes } diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 68857a32f68..5bd96d12074 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -260,7 +260,7 @@ runAllComponentsM (mblk, mhdr, a, b, c, d, e, f, g, h) = do type TestConstraints blk = ( ConsensusProtocol (BlockProtocol blk) , LedgerSupportsProtocol blk - , Eq (ConsensusState (BlockProtocol blk)) + , Eq (ChainDepState (BlockProtocol blk)) , Eq (LedgerState blk) , Eq blk , Show blk diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/LedgerDB/InMemory.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/LedgerDB/InMemory.hs index dbe813de490..61a49691bff 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/LedgerDB/InMemory.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/LedgerDB/InMemory.hs @@ -27,7 +27,7 @@ import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config.SecurityParam import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Util +import Ouroboros.Consensus.Util hiding (Trivial (..)) import Ouroboros.Consensus.Storage.LedgerDB.InMemory diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs index f0569bcfd16..ba1d19f2517 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs @@ -657,6 +657,7 @@ mkTestConfig k ChunkSize { chunkCanContainEBB, numRegularBlocks } = , bftSignKey = SignKeyMockDSIGN 0 , bftVerKeys = Map.singleton (CoreId (CoreNodeId 0)) (VerKeyMockDSIGN 0) } + , configIndep = () , configLedger = eraParams , configBlock = TestBlockConfig { testBlockEBBsAllowed = chunkCanContainEBB @@ -727,7 +728,7 @@ instance EncodeDiskDep (NestedCtxt Header) TestBlock instance DecodeDiskDepIx (NestedCtxt Header) TestBlock instance DecodeDiskDep (NestedCtxt Header) TestBlock --- ConsensusState +-- ChainDepState instance EncodeDisk TestBlock () instance DecodeDisk TestBlock ()