From a0f2ead465bd26b39e504531a5e0111ef192ccbe Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 22 Oct 2020 11:59:23 +0200 Subject: [PATCH] Update dependencies Highlights: * https://github.com/input-output-hk/cardano-ledger-specs/pull/1915 * https://github.com/input-output-hk/cardano-ledger-specs/pull/1922 * https://github.com/input-output-hk/cardano-ledger-specs/pull/1902 * https://github.com/input-output-hk/cardano-ledger-specs/pull/1923 * https://github.com/input-output-hk/cardano-ledger-specs/pull/1927 * https://github.com/input-output-hk/cardano-ledger-specs/pull/1929 --- cabal.project | 13 +- .../src/Test/Consensus/Cardano/Examples.hs | 7 +- .../src/Test/Consensus/Cardano/Generators.hs | 10 +- .../src/Test/Consensus/Cardano/MockCrypto.hs | 16 +- .../src/Test/ThreadNet/TxGen/Cardano.hs | 26 +- .../test/Test/ThreadNet/Cardano.hs | 8 +- .../test/golden/disk/ExtLedgerState_Shelley | Bin 716 -> 716 bytes .../test/golden/disk/LedgerState_Shelley | Bin 471 -> 471 bytes .../ouroboros-consensus-cardano.cabal | 1 + .../src/Ouroboros/Consensus/Cardano.hs | 1 - .../src/Ouroboros/Consensus/Cardano/Block.hs | 2 +- .../Consensus/Cardano/CanHardFork.hs | 233 ++++++++++-------- .../Ouroboros/Consensus/Cardano/Condense.hs | 9 +- .../src/Ouroboros/Consensus/Cardano/Node.hs | 30 ++- .../Ouroboros/Consensus/Cardano/ShelleyHFC.hs | 7 +- .../tools/db-analyser/Block/Byron.hs | 9 +- .../tools/db-analyser/Block/Cardano.hs | 4 +- .../tools/db-analyser/Block/Shelley.hs | 50 ++-- .../tools/db-analyser/HasAnalysis.hs | 16 +- .../tools/db-analyser/Main.hs | 6 +- .../src/Test/Consensus/Shelley/Examples.hs | 76 +++--- .../src/Test/Consensus/Shelley/Generators.hs | 24 +- .../src/Test/Consensus/Shelley/MockCrypto.hs | 18 +- .../src/Test/ThreadNet/Infra/Shelley.hs | 131 +++++----- .../src/Test/ThreadNet/TxGen/Shelley.hs | 11 +- .../Test/Consensus/Shelley/Serialisation.hs | 2 +- .../test/Test/ThreadNet/Shelley.hs | 6 +- .../test/golden/disk/ExtLedgerState | Bin 666 -> 666 bytes .../test/golden/disk/LedgerState | Bin 446 -> 446 bytes .../src/Ouroboros/Consensus/Shelley/Eras.hs | 50 +++- .../Consensus/Shelley/Ledger/Block.hs | 85 ++++--- .../Consensus/Shelley/Ledger/Config.hs | 27 +- .../Consensus/Shelley/Ledger/Forge.hs | 19 +- .../Consensus/Shelley/Ledger/Inspect.hs | 11 +- .../Consensus/Shelley/Ledger/Integrity.hs | 11 +- .../Consensus/Shelley/Ledger/Ledger.hs | 130 ++++++---- .../Consensus/Shelley/Ledger/Mempool.hs | 42 ++-- .../Consensus/Shelley/Ledger/TPraos.hs | 15 +- .../src/Ouroboros/Consensus/Shelley/Node.hs | 36 +-- .../Consensus/Shelley/Node/Serialisation.hs | 58 ++--- .../Ouroboros/Consensus/Shelley/Protocol.hs | 176 +++++++------ .../Consensus/Shelley/Protocol/Crypto.hs | 22 +- .../Consensus/Shelley/Protocol/HotKey.hs | 44 ++-- 43 files changed, 797 insertions(+), 645 deletions(-) diff --git a/cabal.project b/cabal.project index d0d0ceed2b8..f9ad37583b7 100644 --- a/cabal.project +++ b/cabal.project @@ -131,8 +131,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-prelude - tag: a5519e09958ad1605ed438d26dd7aad39167d0f9 - --sha256: 03v46yn5bnkmwcm1zwihjhqvma4ssh3s1s1bfdizvq18y1janwf1 + tag: bec71e48b027b2022e7be1fb7dd265bbbd80490b + --sha256: 0jnxa9m84ka799a3i863sqvlygzf18941pi00d88ar45qdmzkagm subdir: cardano-prelude cardano-prelude-test @@ -140,8 +140,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-base - tag: 72399b18f1bb7d91b21bc9e0e3c28715cde7d124 - --sha256: 014jw9jkwq3z30hl5pc0in51hzxrdys4964vpppmn1nim994bykx + tag: 6012e2fcbddc516490fcae07aad8d3e96fd729e3 + --sha256: 1y64bjl83n2idrhyjwh10frmpiv7lqmbmrixaswvxg36r2iddrqk subdir: binary binary/test @@ -152,8 +152,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger-specs - tag: d5eaac6c4b21a8e69dc3a5503a72e3c3bfde648e - --sha256: 1lzwfi6bc7z995s345ij6aachsrmhmrgm71060z6rvk1w97b3jqk + tag: 1a2d7717682f8191cf818362df28ac20fac19b83 + --sha256: 136pp0653w8chk53wnz6mlkdhf0ldglrb74p1i93d1xnf6ssvjhs subdir: byron/chain/executable-spec byron/crypto @@ -166,6 +166,7 @@ source-repository-package shelley/chain-and-ledger/dependencies/non-integer shelley/chain-and-ledger/executable-spec shelley/chain-and-ledger/shelley-spec-ledger-test + shelley-ma/impl source-repository-package type: git diff --git a/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Examples.hs b/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Examples.hs index bc05a48d9fa..53d2195c125 100644 --- a/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Examples.hs +++ b/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Examples.hs @@ -44,7 +44,6 @@ import qualified Ouroboros.Consensus.Byron.Ledger as Byron import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley -import Ouroboros.Consensus.Shelley.Protocol (StandardCrypto) import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.CanHardFork () @@ -196,9 +195,9 @@ codecConfig :: CardanoCodecConfig Crypto codecConfig = CardanoCodecConfig Byron.codecConfig - Shelley.codecConfig - Shelley.codecConfig - Shelley.codecConfig + Shelley.ShelleyCodecConfig + Shelley.ShelleyCodecConfig + Shelley.ShelleyCodecConfig {------------------------------------------------------------------------------- Additional injections diff --git a/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs b/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs index 1dbbbf4936f..bebb2de2e1f 100644 --- a/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs +++ b/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs @@ -63,6 +63,8 @@ instance Arbitrary (CardanoBlock MockCryptoCompatByron) where arbitrary = oneof [ BlockByron <$> arbitrary , BlockShelley <$> arbitrary + , BlockAllegra <$> arbitrary + , BlockMary <$> arbitrary ] instance Arbitrary (CardanoHeader MockCryptoCompatByron) where @@ -114,7 +116,7 @@ arbitraryHardForkState _ = coerce <$> oneof genPast :: Gen Past genPast = Past <$> arbitrary <*> arbitrary -instance (c ~ MockCryptoCompatByron, Era (ShelleyEra c)) +instance (c ~ MockCryptoCompatByron, ShelleyBasedEra (ShelleyEra c)) => Arbitrary (CardanoLedgerState c) where arbitrary = arbitraryHardForkState (Proxy @LedgerState) @@ -132,13 +134,17 @@ instance (CanMock (ShelleyEra c), CardanoHardForkConstraints c) arbitrary = OneEraHash <$> oneof [ toShortRawHash (Proxy @ByronBlock) <$> arbitrary , toShortRawHash (Proxy @(ShelleyBlock (ShelleyEra c))) <$> arbitrary + , toShortRawHash (Proxy @(ShelleyBlock (AllegraEra c))) <$> arbitrary + , toShortRawHash (Proxy @(ShelleyBlock (MaryEra c))) <$> arbitrary ] -instance (c ~ MockCryptoCompatByron, Era (ShelleyEra c)) +instance (c ~ MockCryptoCompatByron, ShelleyBasedEra (ShelleyEra c)) => Arbitrary (AnnTip (CardanoBlock c)) where arbitrary = oneof [ mapAnnTip TipInfoByron <$> arbitrary @(AnnTip (ByronBlock)) , mapAnnTip TipInfoShelley <$> arbitrary @(AnnTip (ShelleyBlock (ShelleyEra c))) + , mapAnnTip TipInfoAllegra <$> arbitrary @(AnnTip (ShelleyBlock (AllegraEra c))) + , mapAnnTip TipInfoMary <$> arbitrary @(AnnTip (ShelleyBlock (MaryEra c))) ] {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/MockCrypto.hs b/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/MockCrypto.hs index b473776bfdf..bb10736f333 100644 --- a/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/MockCrypto.hs +++ b/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/MockCrypto.hs @@ -3,9 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Consensus.Cardano.MockCrypto ( - BlockCompatByron - , MockShelleyCompatByron - , MockCryptoCompatByron + MockCryptoCompatByron ) where import Cardano.Crypto.DSIGN (Ed25519DSIGN) @@ -13,10 +11,8 @@ import Cardano.Crypto.Hash (Blake2b_224, Blake2b_256) import Cardano.Crypto.KES (MockKES) import Cardano.Ledger.Crypto (Crypto (..)) -import Cardano.Ledger.Shelley (Shelley) import Test.Cardano.Crypto.VRF.Fake (FakeVRF) -import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import Ouroboros.Consensus.Shelley.Protocol.Crypto (TPraosCrypto) -- | A replacement for 'Test.Consensus.Shelley.MockCrypto' that is compatible @@ -35,8 +31,8 @@ import Ouroboros.Consensus.Shelley.Protocol.Crypto (TPraosCrypto) -- * We can still use mock KES and mock VRF. -- -- Note that many Shelley generators are not instantiated to 'MockShelley' but --- are constrained by @'CanMock' era@. 'MockShelleyCompatByron' satisfies this --- constraint, allowing us to reuse these generators for Cardano. +-- are constrained by @'CanMock' era@. @'ShelleyEra' 'MockCryptoCompatByron'@ +-- satisfies this constraint, allowing us to reuse these generators for Cardano. data MockCryptoCompatByron instance Crypto MockCryptoCompatByron where @@ -46,8 +42,4 @@ instance Crypto MockCryptoCompatByron where type KES MockCryptoCompatByron = MockKES 10 type VRF MockCryptoCompatByron = FakeVRF -type MockShelleyCompatByron = Shelley MockCryptoCompatByron - -instance TPraosCrypto MockShelleyCompatByron - -type BlockCompatByron = ShelleyBlock MockShelleyCompatByron +instance TPraosCrypto MockCryptoCompatByron diff --git a/ouroboros-consensus-cardano-test/src/Test/ThreadNet/TxGen/Cardano.hs b/ouroboros-consensus-cardano-test/src/Test/ThreadNet/TxGen/Cardano.hs index bbd2c579a3c..77f8b283a81 100644 --- a/ouroboros-consensus-cardano-test/src/Test/ThreadNet/TxGen/Cardano.hs +++ b/ouroboros-consensus-cardano-test/src/Test/ThreadNet/TxGen/Cardano.hs @@ -65,7 +65,7 @@ import Test.ThreadNet.TxGen data CardanoTxGenExtra c = CardanoTxGenExtra { ctgeByronGenesisKeys :: GeneratedSecrets , ctgeNetworkMagic :: Byron.NetworkMagic - , ctgeShelleyCoreNodes :: [Shelley.CoreNode (ShelleyEra c)] + , ctgeShelleyCoreNodes :: [Shelley.CoreNode c] } instance CardanoHardForkConstraints c => TxGen (CardanoBlock c) where @@ -108,19 +108,19 @@ instance CardanoHardForkConstraints c => TxGen (CardanoBlock c) where -- Reuse the payment key as the pool key, since it's an individual -- stake pool and the namespaces are separate. - poolSK :: SL.SignKeyDSIGN (ShelleyEra c) + poolSK :: SL.SignKeyDSIGN c poolSK = paymentSK -- | See 'migrateUTxO' -data MigrationInfo era = MigrationInfo +data MigrationInfo c = MigrationInfo { byronMagic :: Byron.NetworkMagic -- ^ Needed for creating a Byron address. , byronSK :: Byron.SigningKey -- ^ The core node's Byron secret. - , paymentSK :: SL.SignKeyDSIGN era - , poolSK :: SL.SignKeyDSIGN era - , stakingSK :: SL.SignKeyDSIGN era - , vrfSK :: SL.SignKeyVRF era + , paymentSK :: SL.SignKeyDSIGN c + , poolSK :: SL.SignKeyDSIGN c + , stakingSK :: SL.SignKeyDSIGN c + , vrfSK :: SL.SignKeyVRF c -- ^ To be re-used by the individual pool. } @@ -135,7 +135,7 @@ data MigrationInfo era = MigrationInfo -- 'byronAddr' (eg if this transaction has already been applied). migrateUTxO :: forall c. CardanoHardForkConstraints c - => MigrationInfo (ShelleyEra c) + => MigrationInfo c -> SlotNo -> LedgerConfig (CardanoBlock c) -> LedgerState (CardanoBlock c) @@ -187,7 +187,7 @@ migrateUTxO migrationInfo curSlot lcfg lst , SL._wdrls = SL.Wdrl Map.empty } - bodyHash :: SL.Hash (ShelleyEra c) (SL.TxBody (ShelleyEra c)) + bodyHash :: SL.Hash c (SL.TxBody (ShelleyEra c)) bodyHash = SL.hashWithSerialiser toCBOR body -- Witness the use of bootstrap address's utxo. @@ -197,18 +197,18 @@ migrateUTxO migrationInfo curSlot lcfg lst Byron.addrAttributes byronAddr -- Witness the stake delegation. - delegWit :: SL.WitVKey (ShelleyEra c) 'SL.Witness + delegWit :: SL.WitVKey 'SL.Witness (ShelleyEra c) delegWit = SL.WitVKey (Shelley.mkVerKey stakingSK) - (SL.signedDSIGN @(ShelleyEra c) stakingSK bodyHash) + (SL.signedDSIGN @c stakingSK bodyHash) -- Witness the pool registration. - poolWit :: SL.WitVKey (ShelleyEra c) 'SL.Witness + poolWit :: SL.WitVKey 'SL.Witness (ShelleyEra c) poolWit = SL.WitVKey (Shelley.mkVerKey poolSK) - (SL.signedDSIGN @(ShelleyEra c) poolSK bodyHash) + (SL.signedDSIGN @c poolSK bodyHash) in if Map.null picked then Nothing else diff --git a/ouroboros-consensus-cardano-test/test/Test/ThreadNet/Cardano.hs b/ouroboros-consensus-cardano-test/test/Test/ThreadNet/Cardano.hs index 1d1ae4e9f42..a0ca378738b 100644 --- a/ouroboros-consensus-cardano-test/test/Test/ThreadNet/Cardano.hs +++ b/ouroboros-consensus-cardano-test/test/Test/ThreadNet/Cardano.hs @@ -501,7 +501,7 @@ prop_simple_cardano_convergence TestSetup initialKESPeriod :: SL.KESPeriod initialKESPeriod = SL.KESPeriod 0 - coreNodes :: [Shelley.CoreNode (ShelleyEra Crypto)] + coreNodes :: [Shelley.CoreNode Crypto] coreNodes = runGen initSeed $ replicateM (fromIntegral n) $ Shelley.genCoreNode initialKESPeriod @@ -516,7 +516,7 @@ prop_simple_cardano_convergence TestSetup activeSlotCoeff setupD setupSlotLengthShelley - (Shelley.mkKesConfig (Proxy @(ShelleyEra Crypto)) numSlots) + (Shelley.mkKesConfig (Proxy @Crypto) numSlots) coreNodes -- the Shelley ledger is designed to use a fixed epoch size, so this test @@ -710,7 +710,7 @@ mkProtocolCardanoAndHardForkTxs -- Shelley -> ShelleyGenesis (ShelleyEra c) -> SL.Nonce - -> Shelley.CoreNode (ShelleyEra c) + -> Shelley.CoreNode c -- HardForks -> ProtocolParamsTransition ByronBlock @@ -790,7 +790,7 @@ mkProtocolCardanoAndHardForkTxs -- Shelley - leaderCredentialsShelley :: TPraosLeaderCredentials (ShelleyEra c) + leaderCredentialsShelley :: TPraosLeaderCredentials c leaderCredentialsShelley = Shelley.mkLeaderCredentials coreNodeShelley {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-cardano-test/test/golden/disk/ExtLedgerState_Shelley b/ouroboros-consensus-cardano-test/test/golden/disk/ExtLedgerState_Shelley index dfe0ce521d9bf83cdef68cc5de13afa87fe4c872..4006b2e51a0fe3e79a7f977fdd2745a55349bf2c 100644 GIT binary patch delta 25 hcmX@ZdWLmFCL_B<%EBgw2$_iwWf_?__c7Wr0swIK2kQU; delta 25 hcmX@ZdWLmFCL_B=^1>#D2$_iwWf_$=_c7Wr0swQs2q^#n diff --git a/ouroboros-consensus-cardano-test/test/golden/disk/LedgerState_Shelley b/ouroboros-consensus-cardano-test/test/golden/disk/LedgerState_Shelley index 283caedebb95d49b84d6386cbb5fdca0f14a3a82..d0e9fa3bb962296a3ac85795ca4d5fb15f44ed38 100644 GIT binary patch delta 24 gcmcc4e4TkiCL_B<%EBgw2$_iwWf_?#_c3|`0BSe~=Kufz delta 24 gcmcc4e4TkiCL_B=^1>#D2$_iwWf_$w_c3|`0BpnvB>(^b diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 9c4d80f8c21..aa613bc521e 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -49,6 +49,7 @@ library , cardano-prelude , cardano-slotting , shelley-spec-ledger + , cardano-ledger-shelley-ma , ouroboros-network , ouroboros-consensus diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs index 4312409b3f5..1df49960f92 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs @@ -53,7 +53,6 @@ import Ouroboros.Consensus.Byron.Node as X import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node as X -import Ouroboros.Consensus.Shelley.Protocol (StandardCrypto) import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.ByronHFC diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Block.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Block.hs index 1dd12d8d271..c03b3af9f5d 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Block.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Block.hs @@ -168,7 +168,7 @@ type CardanoEras c = -- > f (BlockByron b) = _ -- > f (BlockShelley s) = _ -- > f (BlockAllegra a) = _ --- > f (BlockAllegra m) = _ +-- > f (BlockMary m) = _ -- type CardanoBlock c = HardForkBlock (CardanoEras c) diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs index b6d546818ea..b5ffc01044a 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -13,6 +14,8 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Cardano.CanHardFork ( TriggerHardFork (..) @@ -26,7 +29,8 @@ import Control.Monad.Except (Except, throwError) import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe, mapMaybe) import Data.Proxy -import Data.SOP.Strict (NP (..)) +import Data.SOP.Strict ((:.:) (..), NP (..)) +import Data.Void (Void) import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -64,9 +68,10 @@ import qualified Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect import Ouroboros.Consensus.Shelley.Node () import Ouroboros.Consensus.Shelley.Protocol +import Cardano.Ledger.Allegra.Translation () import Cardano.Ledger.Crypto (ADDRHASH, DSIGN, HASH) -import qualified Cardano.Ledger.Era as Era - +import qualified Cardano.Ledger.Era as SL +import Cardano.Ledger.Mary.Translation () import qualified Shelley.Spec.Ledger.API as SL import Ouroboros.Consensus.Cardano.Block @@ -290,7 +295,7 @@ instance HasPartialLedgerConfig ByronBlock where SingleEraBlock Shelley -------------------------------------------------------------------------------} -instance TPraosCrypto era => SingleEraBlock (ShelleyBlock era) where +instance ShelleyBasedEra era => SingleEraBlock (ShelleyBlock era) where singleEraTransition pcfg _eraParams _eraStart ledgerState = case shelleyTriggerHardFork pcfg of TriggerHardForkNever -> Nothing @@ -305,8 +310,8 @@ instance TPraosCrypto era => SingleEraBlock (ShelleyBlock era) where singleEraName = "Shelley" } -instance TPraosCrypto era => HasPartialConsensusConfig (TPraos era) where - type PartialConsensusConfig (TPraos era) = TPraosParams +instance TPraosCrypto c => HasPartialConsensusConfig (TPraos c) where + type PartialConsensusConfig (TPraos c) = TPraosParams completeConsensusConfig _ tpraosEpochInfo tpraosParams = TPraosConfig {..} @@ -326,7 +331,7 @@ data ShelleyPartialLedgerConfig era = ShelleyPartialLedgerConfig { } deriving (Generic, NoThunks) -instance TPraosCrypto era => HasPartialLedgerConfig (ShelleyBlock era) where +instance ShelleyBasedEra era => HasPartialLedgerConfig (ShelleyBlock era) where type PartialLedgerConfig (ShelleyBlock era) = ShelleyPartialLedgerConfig era -- Replace the dummy 'EpochInfo' with the real one @@ -342,7 +347,10 @@ instance TPraosCrypto era => HasPartialLedgerConfig (ShelleyBlock era) where -------------------------------------------------------------------------------} type CardanoHardForkConstraints c = - ( TPraosCrypto (ShelleyEra c) + ( TPraosCrypto c + , ShelleyBasedEra (ShelleyEra c) + , ShelleyBasedEra (AllegraEra c) + , ShelleyBasedEra (MaryEra c) -- These equalities allow the transition from Byron to Shelley, since -- @shelley-spec-ledger@ requires Ed25519 for Byron bootstrap addresses and -- the current Byron-to-Shelley translation requires a 224-bit hash for @@ -361,13 +369,13 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where $ PNil , translateChainDepState = PCons translateChainDepStateByronToShelleyWrapper - $ PCons translateChainDepStateShelleyToAllegraWrapper - $ PCons translateChainDepStateAllegraToMaryWrapper + $ PCons translateChainDepStateAcrossShelley + $ PCons translateChainDepStateAcrossShelley $ PNil , translateLedgerView = PCons translateLedgerViewByronToShelleyWrapper - $ PCons translateLedgerViewShelleyToAllegraWrapper - $ PCons translateLedgerViewAllegraToMaryWrapper + $ PCons translateLedgerViewAcrossShelley + $ PCons translateLedgerViewAcrossShelley $ PNil } hardForkChainSel = @@ -391,21 +399,26 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where -------------------------------------------------------------------------------} translateHeaderHashByronToShelley :: - forall era. (Era era, HASH (Era.Crypto era) ~ Blake2b_256) + forall c. + ( ShelleyBasedEra (ShelleyEra c) + , HASH c ~ Blake2b_256 + ) => HeaderHash ByronBlock - -> HeaderHash (ShelleyBlock era) + -> HeaderHash (ShelleyBlock (ShelleyEra c)) translateHeaderHashByronToShelley = - fromShortRawHash (Proxy @(ShelleyBlock era)) + fromShortRawHash (Proxy @(ShelleyBlock (ShelleyEra c))) . toShortRawHash (Proxy @ByronBlock) where -- Byron uses 'Blake2b_256' for header hashes - _ = keepRedundantConstraint (Proxy @(HASH (Era.Crypto era) ~ Blake2b_256)) + _ = keepRedundantConstraint (Proxy @(HASH c ~ Blake2b_256)) translatePointByronToShelley :: - forall era. (Era era, HASH (Era.Crypto era) ~ Blake2b_256) + ( ShelleyBasedEra (ShelleyEra c) + , HASH c ~ Blake2b_256 + ) => Point ByronBlock -> WithOrigin BlockNo - -> WithOrigin (ShelleyTip era) + -> WithOrigin (ShelleyTip (ShelleyEra c)) translatePointByronToShelley point bNo = case (point, bNo) of (GenesisPoint, Origin) -> @@ -419,15 +432,15 @@ translatePointByronToShelley point bNo = error "translatePointByronToShelley: invalid Byron state" translateLedgerStateByronToShelleyWrapper :: - ( Era era - , HASH (Era.Crypto era) ~ Blake2b_256 - , ADDRHASH (Era.Crypto era) ~ Blake2b_224 + ( ShelleyBasedEra (ShelleyEra c) + , HASH c ~ Blake2b_256 + , ADDRHASH c ~ Blake2b_224 ) => RequiringBoth WrapLedgerConfig (Translate LedgerState) ByronBlock - (ShelleyBlock era) + (ShelleyBlock (ShelleyEra c)) translateLedgerStateByronToShelleyWrapper = RequireBoth $ \_ (WrapLedgerConfig cfgShelley) -> Translate $ \epochNo ledgerByron -> @@ -445,24 +458,23 @@ translateLedgerStateByronToShelleyWrapper = ShelleyTransitionInfo{shelleyAfterVoting = 0} } -translateChainDepStateByronToShelleyWrapper - :: forall era. +translateChainDepStateByronToShelleyWrapper :: RequiringBoth WrapConsensusConfig (Translate WrapChainDepState) ByronBlock - (ShelleyBlock era) + (ShelleyBlock (ShelleyEra c)) translateChainDepStateByronToShelleyWrapper = RequireBoth $ \_ (WrapConsensusConfig cfgShelley) -> Translate $ \_ (WrapChainDepState pbftState) -> WrapChainDepState $ translateChainDepStateByronToShelley cfgShelley pbftState -translateChainDepStateByronToShelley - :: forall bc era. - ConsensusConfig (TPraos era) +translateChainDepStateByronToShelley :: + forall bc c. + ConsensusConfig (TPraos c) -> PBftState bc - -> TPraosState era + -> TPraosState c translateChainDepStateByronToShelley TPraosConfig { tpraosParams } pbftState = -- Note that the 'PBftState' doesn't know about EBBs. So if the last slot of -- the Byron era were occupied by an EBB (and no regular block in that same @@ -490,12 +502,12 @@ translateChainDepStateByronToShelley TPraosConfig { tpraosParams } pbftState = nonce = tpraosInitialNonce tpraosParams translateLedgerViewByronToShelleyWrapper :: - forall era. + forall c. RequiringBoth WrapLedgerConfig (TranslateForecast LedgerState WrapLedgerView) ByronBlock - (ShelleyBlock era) + (ShelleyBlock (ShelleyEra c)) translateLedgerViewByronToShelleyWrapper = RequireBoth $ \_ (WrapLedgerConfig cfgShelley) -> TranslateForecast (forecast cfgShelley) @@ -508,11 +520,13 @@ translateLedgerViewByronToShelleyWrapper = -- is still guaranteed to be less than the forecast range of the HFC in the -- Byron era. forecast :: - ShelleyLedgerConfig era + ShelleyLedgerConfig (ShelleyEra c) -> Bound -> SlotNo -> LedgerState ByronBlock - -> Except OutsideForecastRange (Ticked (WrapLedgerView (ShelleyBlock era))) + -> Except + OutsideForecastRange + (Ticked (WrapLedgerView (ShelleyBlock (ShelleyEra c)))) forecast cfgShelley bound forecastFor currentByronState | forecastFor < maxFor = return $ @@ -542,48 +556,43 @@ translateLedgerViewByronToShelleyWrapper = maxFor = addSlots swindow (boundSlot bound) {------------------------------------------------------------------------------- - Translation from Shelley to Allegra + Translation from one Shelley-based era to another Shelley-based era -------------------------------------------------------------------------------} -translateLedgerStateShelleyToAllegraWrapper :: - RequiringBoth - WrapLedgerConfig - (Translate LedgerState) - (ShelleyBlock (ShelleyEra c)) - (ShelleyBlock (AllegraEra c)) -translateLedgerStateShelleyToAllegraWrapper = - ignoringBoth $ - Translate $ \_epochNo ledgerShelley -> ledgerShelley - -translateChainDepStateShelleyToAllegraWrapper :: - RequiringBoth - WrapConsensusConfig - (Translate WrapChainDepState) - (ShelleyBlock (ShelleyEra c)) - (ShelleyBlock (AllegraEra c)) -translateChainDepStateShelleyToAllegraWrapper = - ignoringBoth $ - Translate $ \_epochNo (WrapChainDepState stateShelley) -> - WrapChainDepState stateShelley +instance ( ShelleyBasedEra era + , ShelleyBasedEra (SL.PreviousEra era) + , EraCrypto (SL.PreviousEra era) ~ EraCrypto era + ) => SL.TranslateEra era ShelleyTip where + translateEra _ (ShelleyTip sno bno (ShelleyHash hash)) = + return $ ShelleyTip sno bno (ShelleyHash hash) + +instance ( ShelleyBasedEra era + , SL.TranslateEra era ShelleyTip + , SL.TranslateEra era SL.NewEpochState + , SL.TranslationError era SL.NewEpochState ~ Void + ) => SL.TranslateEra era (LedgerState :.: ShelleyBlock) where + translateEra ctxt (Comp (ShelleyLedgerState tip state _transition)) = do + tip' <- mapM (SL.translateEra ctxt) tip + state' <- SL.translateEra ctxt state + return $ Comp $ ShelleyLedgerState { + shelleyLedgerTip = tip' + , shelleyLedgerState = state' + , shelleyLedgerTransition = ShelleyTransitionInfo 0 + } -translateLedgerViewShelleyToAllegraWrapper :: - TPraosCrypto (ShelleyEra c) - => RequiringBoth - WrapLedgerConfig - (TranslateForecast LedgerState WrapLedgerView) - (ShelleyBlock (ShelleyEra c)) - (ShelleyBlock (AllegraEra c)) -translateLedgerViewShelleyToAllegraWrapper = - RequireBoth $ \(WrapLedgerConfig cfgShelley) - (WrapLedgerConfig cfgAllegra) -> - TranslateForecast $ forecastAcrossShelley cfgShelley cfgAllegra +instance ( ShelleyBasedEra era + , SL.TranslateEra era SL.Tx + ) => SL.TranslateEra era (GenTx :.: ShelleyBlock) where + type TranslationError era (GenTx :.: ShelleyBlock) = SL.TranslationError era SL.Tx + translateEra ctxt (Comp (ShelleyTx _txId tx)) = + -- TODO will the txId stay the same? If so, we could avoid recomputing it + Comp . mkShelleyTx <$> SL.translateEra ctxt tx -- | Forecast from a Shelley-based era to the next Shelley-based era. forecastAcrossShelley :: - ( TPraosCrypto eraFrom - -- TODO #2668 remove this constraint and use the translation infrastructure - -- from the ledger when in place - , eraFrom ~ eraTo + forall eraFrom eraTo. + ( EraCrypto eraFrom ~ EraCrypto eraTo + , ShelleyBasedEra eraFrom ) => ShelleyLedgerConfig eraFrom -> ShelleyLedgerConfig eraTo @@ -593,10 +602,7 @@ forecastAcrossShelley :: -> Except OutsideForecastRange (Ticked (WrapLedgerView (ShelleyBlock eraTo))) forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom | forecastFor < maxFor - = return $ - WrapTickedLedgerView $ TickedPraosLedgerView $ - SL.mkInitialShelleyLedgerView - (shelleyLedgerGenesis cfgTo) + = return $ futureLedgerView forecastFor | otherwise = throwError $ OutsideForecastRange { outsideForecastAt = ledgerTipSlot ledgerStateFrom @@ -604,6 +610,19 @@ forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom , outsideForecastFor = forecastFor } where + -- | 'SL.futureLedgerView' imposes its own bounds. Those bounds could + -- /exceed/ the 'maxFor' we have computed, but should never be /less/. + futureLedgerView :: SlotNo -> Ticked (WrapLedgerView (ShelleyBlock eraTo)) + futureLedgerView = + WrapTickedLedgerView + . TickedPraosLedgerView + . either + (\e -> error ("futureLedgerView failed: " <> show e)) + id + . SL.futureLedgerView + (shelleyLedgerGlobals cfgFrom) + (shelleyLedgerState ledgerStateFrom) + -- Exclusive upper bound maxFor :: SlotNo maxFor = crossEraForecastBound @@ -612,6 +631,51 @@ forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom (SL.stabilityWindow (shelleyLedgerGlobals cfgFrom)) (SL.stabilityWindow (shelleyLedgerGlobals cfgTo)) +translateChainDepStateAcrossShelley :: + forall eraFrom eraTo. + EraCrypto eraFrom ~ EraCrypto eraTo + => RequiringBoth + WrapConsensusConfig + (Translate WrapChainDepState) + (ShelleyBlock eraFrom) + (ShelleyBlock eraTo) +translateChainDepStateAcrossShelley = + ignoringBoth $ + Translate $ \_epochNo (WrapChainDepState chainDepState) -> + -- Same protocol, same 'ChainDepState'. Note that we don't have to apply + -- any changes related to an epoch transition, this is already done when + -- ticking the state. + WrapChainDepState chainDepState + +translateLedgerViewAcrossShelley :: + forall eraFrom eraTo. + ( EraCrypto eraFrom ~ EraCrypto eraTo + , ShelleyBasedEra eraFrom + ) + => RequiringBoth + WrapLedgerConfig + (TranslateForecast LedgerState WrapLedgerView) + (ShelleyBlock eraFrom) + (ShelleyBlock eraTo) +translateLedgerViewAcrossShelley = + RequireBoth $ \(WrapLedgerConfig cfgFrom) + (WrapLedgerConfig cfgTo) -> + TranslateForecast $ forecastAcrossShelley cfgFrom cfgTo + +{------------------------------------------------------------------------------- + Translation from Shelley to Allegra +-------------------------------------------------------------------------------} + +translateLedgerStateShelleyToAllegraWrapper :: + RequiringBoth + WrapLedgerConfig + (Translate LedgerState) + (ShelleyBlock (ShelleyEra c)) + (ShelleyBlock (AllegraEra c)) +translateLedgerStateShelleyToAllegraWrapper = + ignoringBoth $ + Translate $ \_epochNo ledgerShelley -> ledgerShelley + translateTxShelleyToAllegraWrapper :: InjectTx (ShelleyBlock (ShelleyEra c)) @@ -632,29 +696,6 @@ translateLedgerStateAllegraToMaryWrapper = ignoringBoth $ Translate $ \_epochNo ledgerAllegra -> ledgerAllegra -translateChainDepStateAllegraToMaryWrapper :: - RequiringBoth - WrapConsensusConfig - (Translate WrapChainDepState) - (ShelleyBlock (AllegraEra c)) - (ShelleyBlock (MaryEra c)) -translateChainDepStateAllegraToMaryWrapper = - ignoringBoth $ - Translate $ \_epochNo (WrapChainDepState stateAllegra) -> - WrapChainDepState stateAllegra - -translateLedgerViewAllegraToMaryWrapper :: - TPraosCrypto (AllegraEra c) - => RequiringBoth - WrapLedgerConfig - (TranslateForecast LedgerState WrapLedgerView) - (ShelleyBlock (AllegraEra c)) - (ShelleyBlock (MaryEra c)) -translateLedgerViewAllegraToMaryWrapper = - RequireBoth $ \(WrapLedgerConfig cfgAllegra) - (WrapLedgerConfig cfgMary) -> - TranslateForecast $ forecastAcrossShelley cfgAllegra cfgMary - translateTxAllegraToMaryWrapper :: InjectTx (ShelleyBlock (AllegraEra c)) diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Condense.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Condense.hs index 962d42e0547..9e1ccc06c99 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Condense.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Condense.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Cardano.Condense () where @@ -9,8 +11,7 @@ import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Cardano.Block - -import Cardano.Ledger.Crypto (Crypto) +import Ouroboros.Consensus.Cardano.CanHardFork {------------------------------------------------------------------------------- Condense @@ -20,6 +21,6 @@ import Cardano.Ledger.Crypto (Crypto) instance CondenseConstraints ByronBlock -instance Era era => CondenseConstraints (ShelleyBlock era) +instance ShelleyBasedEra era => CondenseConstraints (ShelleyBlock era) -instance Crypto c => CondenseConstraints (CardanoBlock c) +instance CardanoHardForkConstraints c => CondenseConstraints (CardanoBlock c) diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs index 8a56900519c..9010d407d55 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs @@ -74,8 +74,7 @@ import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion import Ouroboros.Consensus.Shelley.Node -import Ouroboros.Consensus.Shelley.Protocol (TPraosCrypto, - TPraosParams (..)) +import Ouroboros.Consensus.Shelley.Protocol (TPraosParams (..)) import qualified Ouroboros.Consensus.Shelley.Protocol as Shelley import Ouroboros.Consensus.Cardano.Block @@ -86,7 +85,7 @@ import Ouroboros.Consensus.Cardano.CanHardFork -------------------------------------------------------------------------------} instance SerialiseConstraintsHFC ByronBlock -instance TPraosCrypto era => SerialiseConstraintsHFC (ShelleyBlock era) +instance ShelleyBasedEra era => SerialiseConstraintsHFC (ShelleyBlock era) -- | Important: we need to maintain binary compatibility with Byron blocks, as -- they are already stored on disk. @@ -339,7 +338,8 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron { , shelleyLeaderCredentials = mCredsShelley } ProtocolParamsAllegra { - allegraLeaderCredentials = mCredsAllegra + allegraProtVer = protVerAllegra + , allegraLeaderCredentials = mCredsAllegra } ProtocolParamsMary { maryProtVer = protVerMary @@ -451,8 +451,15 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron { -- Allegra + genesisAllegra :: ShelleyGenesis (AllegraEra c) + genesisAllegra = genesisShelley + blockConfigAllegra :: BlockConfig (ShelleyBlock (AllegraEra c)) - blockConfigAllegra = blockConfigShelley + blockConfigAllegra = + Shelley.mkShelleyBlockConfig + protVerAllegra + genesisAllegra + (tpraosBlockIssuerVKey <$> maybeToList mCredsAllegra) partialConsensusConfigAllegra :: PartialConsensusConfig (BlockProtocol (ShelleyBlock (AllegraEra c))) @@ -461,14 +468,21 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron { partialLedgerConfigAllegra :: PartialLedgerConfig (ShelleyBlock (AllegraEra c)) partialLedgerConfigAllegra = mkPartialLedgerConfigShelley - genesisShelley + genesisAllegra maxMajorProtVer triggerHardForkAllegraMary -- Mary + genesisMary :: ShelleyGenesis (MaryEra c) + genesisMary = genesisAllegra + blockConfigMary :: BlockConfig (ShelleyBlock (MaryEra c)) - blockConfigMary = blockConfigShelley + blockConfigMary = + Shelley.mkShelleyBlockConfig + protVerMary + genesisMary + (tpraosBlockIssuerVKey <$> maybeToList mCredsMary) partialConsensusConfigMary :: PartialConsensusConfig (BlockProtocol (ShelleyBlock (MaryEra c))) @@ -477,7 +491,7 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron { partialLedgerConfigMary :: PartialLedgerConfig (ShelleyBlock (MaryEra c)) partialLedgerConfigMary = mkPartialLedgerConfigShelley - genesisShelley + genesisMary maxMajorProtVer TriggerHardForkNever diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyHFC.hs index 1f368a6bd00..2d9719aede3 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyHFC.hs @@ -34,7 +34,7 @@ type ShelleyBlockHFC era = HardForkBlock '[ShelleyBlock era] NoHardForks instance -------------------------------------------------------------------------------} -instance TPraosCrypto era => NoHardForks (ShelleyBlock era) where +instance ShelleyBasedEra era => NoHardForks (ShelleyBlock era) where getEraParams = shelleyEraParamsNeverHardForks . shelleyLedgerGenesis @@ -52,7 +52,8 @@ instance TPraosCrypto era => NoHardForks (ShelleyBlock era) where -- | Forward to the ShelleyBlock instance. Only supports -- 'HardForkNodeToNodeDisabled', which is compatible with nodes running with -- 'ShelleyBlock'. -instance TPraosCrypto era => SupportedNetworkProtocolVersion (ShelleyBlockHFC era) where +instance ShelleyBasedEra era + => SupportedNetworkProtocolVersion (ShelleyBlockHFC era) where supportedNodeToNodeVersions _ = Map.map HardForkNodeToNodeDisabled $ supportedNodeToNodeVersions (Proxy @(ShelleyBlock era)) @@ -68,4 +69,4 @@ instance TPraosCrypto era => SupportedNetworkProtocolVersion (ShelleyBlockHFC er -- | Use the default implementations. This means the serialisation of blocks -- includes an era wrapper. Each block should do this from the start to be -- prepared for future hard forks without having to do any bit twiddling. -instance TPraosCrypto era => SerialiseHFC '[ShelleyBlock era] where +instance ShelleyBasedEra era => SerialiseHFC '[ShelleyBlock era] diff --git a/ouroboros-consensus-cardano/tools/db-analyser/Block/Byron.hs b/ouroboros-consensus-cardano/tools/db-analyser/Block/Byron.hs index a6e98f824e8..0f093758aa5 100644 --- a/ouroboros-consensus-cardano/tools/db-analyser/Block/Byron.hs +++ b/ouroboros-consensus-cardano/tools/db-analyser/Block/Byron.hs @@ -27,7 +27,6 @@ import qualified Cardano.Chain.Update as Update import qualified Cardano.Chain.UTxO as Chain import Ouroboros.Consensus.Node.ProtocolInfo -import Ouroboros.Consensus.Storage.Serialisation (SizeInBytes) import Ouroboros.Consensus.Byron.Ledger (ByronBlock) import qualified Ouroboros.Consensus.Byron.Ledger as Byron @@ -37,6 +36,11 @@ import Ouroboros.Consensus.Byron.Node (PBftSignatureThreshold (..), import HasAnalysis instance HasAnalysis ByronBlock where + countTxOutputs = aBlockOrBoundary (const 0) countTxOutputsByron + blockTxSizes = aBlockOrBoundary (const []) blockTxSizesByron + knownEBBs = const Byron.knownEBBs + +instance HasProtocolInfo ByronBlock where data Args ByronBlock = ByronBlockArgs { configFileByron :: FilePath @@ -48,9 +52,6 @@ instance HasAnalysis ByronBlock where mkProtocolInfo ByronBlockArgs {..} = do config <- openGenesisByron configFileByron genesisHash requiresNetworkMagic return $ mkByronProtocolInfo config threshold - countTxOutputs = aBlockOrBoundary (const 0) countTxOutputsByron - blockTxSizes = aBlockOrBoundary (const []) blockTxSizesByron - knownEBBs = const Byron.knownEBBs type ByronBlockArgs = Args ByronBlock diff --git a/ouroboros-consensus-cardano/tools/db-analyser/Block/Cardano.hs b/ouroboros-consensus-cardano/tools/db-analyser/Block/Cardano.hs index 529a29dbaaf..05d1213234e 100644 --- a/ouroboros-consensus-cardano/tools/db-analyser/Block/Cardano.hs +++ b/ouroboros-consensus-cardano/tools/db-analyser/Block/Cardano.hs @@ -53,7 +53,7 @@ analyseBlock f = p :: Proxy HasAnalysis p = Proxy -instance HasAnalysis (CardanoBlock StandardCrypto) where +instance HasProtocolInfo (CardanoBlock StandardCrypto) where data Args (CardanoBlock StandardCrypto) = CardanoBlockArgs { byronArgs :: Args ByronBlock @@ -67,6 +67,8 @@ instance HasAnalysis (CardanoBlock StandardCrypto) where genesisShelley <- either (error . show) return =<< Aeson.eitherDecodeFileStrict' configFileShelley return $ mkCardanoProtocolInfo genesisByron threshold genesisShelley initialNonce + +instance HasAnalysis (CardanoBlock StandardCrypto) where countTxOutputs = analyseBlock countTxOutputs blockTxSizes = analyseBlock blockTxSizes knownEBBs _ = diff --git a/ouroboros-consensus-cardano/tools/db-analyser/Block/Shelley.hs b/ouroboros-consensus-cardano/tools/db-analyser/Block/Shelley.hs index ee95e4a4d30..02d4951e288 100644 --- a/ouroboros-consensus-cardano/tools/db-analyser/Block/Shelley.hs +++ b/ouroboros-consensus-cardano/tools/db-analyser/Block/Shelley.hs @@ -16,38 +16,53 @@ import Data.Foldable (asum, toList) import qualified Data.Map.Strict as Map import Options.Applicative +import qualified Cardano.Ledger.Core as Core import qualified Shelley.Spec.Ledger.API as SL import qualified Shelley.Spec.Ledger.BlockChain as SL (TxSeq (..)) import Ouroboros.Consensus.Node.ProtocolInfo -import Ouroboros.Consensus.Shelley.Eras (StandardShelley) +import Ouroboros.Consensus.Shelley.Eras (ShelleyBasedEra, + StandardShelley) import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock) import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Shelley import Ouroboros.Consensus.Shelley.Node (Nonce (..), ProtocolParamsShelley (..), ShelleyGenesis, protocolInfoShelley) -import Ouroboros.Consensus.Shelley.Protocol.Crypto import HasAnalysis -instance HasAnalysis (ShelleyBlock StandardShelley) where - data Args (ShelleyBlock StandardShelley) = - ShelleyBlockArgs { - configFileShelley :: FilePath - , initialNonce :: Nonce - } deriving Show - argsParser _ = parseShelleyArgs - mkProtocolInfo ShelleyBlockArgs {..} = do - config <- either (error . show) return =<< - Aeson.eitherDecodeFileStrict' configFileShelley - return $ mkShelleyProtocolInfo config initialNonce - countTxOutputs blk = case Shelley.shelleyBlockRaw blk of +-- | Usable for each Shelley-based era +instance ( ShelleyBasedEra era + -- TODO this will have to be generalised for the real Mary era (and + -- Allegra?), which will have a different 'Core.TxBody'. + , Core.TxBody era ~ SL.TxBody era + ) => HasAnalysis (ShelleyBlock era) where + countTxOutputs blk = case Shelley.shelleyBlockRaw blk of SL.Block _ (SL.TxSeq txs) -> sum $ fmap countOutputs txs - blockTxSizes blk = case Shelley.shelleyBlockRaw blk of + where + countOutputs :: SL.Tx era -> Int + countOutputs = length . SL._outputs . SL._body + + blockTxSizes blk = case Shelley.shelleyBlockRaw blk of SL.Block _ (SL.TxSeq txs) -> toList $ fmap (fromIntegral . BL.length . SL.txFullBytes) txs - knownEBBs = const Map.empty + + knownEBBs = const Map.empty + +-- | Shelley-era specific +instance HasProtocolInfo (ShelleyBlock StandardShelley) where + data Args (ShelleyBlock StandardShelley) = ShelleyBlockArgs { + configFileShelley :: FilePath + , initialNonce :: Nonce + } + deriving (Show) + + argsParser _ = parseShelleyArgs + mkProtocolInfo ShelleyBlockArgs {..} = do + config <- either (error . show) return =<< + Aeson.eitherDecodeFileStrict' configFileShelley + return $ mkShelleyProtocolInfo config initialNonce type ShelleyBlockArgs = Args (ShelleyBlock StandardShelley) @@ -63,9 +78,6 @@ mkShelleyProtocolInfo genesis initialNonce = , shelleyLeaderCredentials = [] } -countOutputs :: TPraosCrypto era => SL.Tx era -> Int -countOutputs tx = length $ SL._outputs $ SL._body tx - parseShelleyArgs :: Parser ShelleyBlockArgs parseShelleyArgs = ShelleyBlockArgs <$> strOption (mconcat [ diff --git a/ouroboros-consensus-cardano/tools/db-analyser/HasAnalysis.hs b/ouroboros-consensus-cardano/tools/db-analyser/HasAnalysis.hs index cca967104e0..f38e4cae406 100644 --- a/ouroboros-consensus-cardano/tools/db-analyser/HasAnalysis.hs +++ b/ouroboros-consensus-cardano/tools/db-analyser/HasAnalysis.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TypeFamilies #-} module HasAnalysis ( HasAnalysis (..) + , HasProtocolInfo (..) + , SizeInBytes ) where import Data.Map.Strict (Map) @@ -15,9 +17,11 @@ import Ouroboros.Consensus.Storage.Serialisation (SizeInBytes) -------------------------------------------------------------------------------} class GetPrevHash blk => HasAnalysis blk where - data Args blk - argsParser :: proxy blk -> Parser (Args blk) - mkProtocolInfo :: Args blk -> IO (ProtocolInfo IO blk) - countTxOutputs :: blk -> Int - blockTxSizes :: blk -> [SizeInBytes] - knownEBBs :: proxy blk -> Map (HeaderHash blk) (ChainHash blk) + countTxOutputs :: blk -> Int + blockTxSizes :: blk -> [SizeInBytes] + knownEBBs :: proxy blk -> Map (HeaderHash blk) (ChainHash blk) + +class HasProtocolInfo blk where + data Args blk + argsParser :: proxy blk -> Parser (Args blk) + mkProtocolInfo :: Args blk -> IO (ProtocolInfo IO blk) diff --git a/ouroboros-consensus-cardano/tools/db-analyser/Main.hs b/ouroboros-consensus-cardano/tools/db-analyser/Main.hs index 4da44978115..1159e4c2577 100644 --- a/ouroboros-consensus-cardano/tools/db-analyser/Main.hs +++ b/ouroboros-consensus-cardano/tools/db-analyser/Main.hs @@ -150,7 +150,11 @@ getCmdLine = execParser opts -------------------------------------------------------------------------------} analyse :: - (Node.RunNode blk, Show (Header blk), HasAnalysis blk) + ( Node.RunNode blk + , Show (Header blk) + , HasAnalysis blk + , HasProtocolInfo blk + ) => CmdLine -> Args blk -> IO () 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 99760d985e7..d553b6d681d 100644 --- a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs @@ -59,18 +59,17 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.Time -import Cardano.Ledger.Crypto (ADDRHASH, DSIGN, VRF) -import Cardano.Ledger.Era (Era (Crypto)) +import Cardano.Ledger.Crypto (ADDRHASH, Crypto, DSIGN, VRF) import Shelley.Spec.Ledger.API (StrictMaybe (..)) import qualified Shelley.Spec.Ledger.API as SL import qualified Shelley.Spec.Ledger.BaseTypes as SL (mkNonceFromNumber, textToUrl) import qualified Shelley.Spec.Ledger.BlockChain as SL (TxSeq (..)) +import qualified Shelley.Spec.Ledger.Coin as SL (DeltaCoin (..)) import qualified Shelley.Spec.Ledger.Delegation.Certificates as SL (IndividualPoolStake (..)) import qualified Shelley.Spec.Ledger.EpochBoundary as SL (BlocksMade (..), emptySnapShots) -import qualified Shelley.Spec.Ledger.Hashing as SL (hashAnnotated) import qualified Shelley.Spec.Ledger.Keys as SL (asWitness, hashWithSerialiser, signedKES) import qualified Shelley.Spec.Ledger.LedgerState as SL (emptyDPState, @@ -86,6 +85,7 @@ import qualified Shelley.Spec.Ledger.STS.Ledgers as SL import qualified Shelley.Spec.Ledger.STS.Utxow as SL (UtxowPredicateFailure (..)) import qualified Shelley.Spec.Ledger.Tx as SL (addrWits) +import qualified Shelley.Spec.Ledger.TxBody as SL (eraIndTxBodyHash) import qualified Shelley.Spec.Ledger.UTxO as SL (makeWitnessesVKey) import qualified Test.Shelley.Spec.Ledger.Generator.Core as SL (AllIssuerKeys (..), genesisId, mkOCert) @@ -93,7 +93,7 @@ import Test.Shelley.Spec.Ledger.Orphans () import qualified Test.Shelley.Spec.Ledger.Utils as SL hiding (mkKeyPair, mkKeyPair', mkVRFKeyPair) -import Ouroboros.Consensus.Shelley.Eras (StandardShelley) +import Ouroboros.Consensus.Shelley.Eras (EraCrypto, StandardShelley) import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Protocol (TPraosCrypto, TPraosState (..)) @@ -138,45 +138,45 @@ codecConfig = ShelleyCodecConfig mkDummyHash :: forall h a. HashAlgorithm h => Proxy h -> Int -> Hash.Hash h a mkDummyHash _ = coerce . SL.hashWithSerialiser @h toCBOR -mkKeyHash :: forall era discriminator. Era era => Int -> SL.KeyHash discriminator era -mkKeyHash = SL.KeyHash . mkDummyHash (Proxy @(ADDRHASH (Crypto era))) +mkKeyHash :: forall c discriminator. Crypto c => Int -> SL.KeyHash discriminator c +mkKeyHash = SL.KeyHash . mkDummyHash (Proxy @(ADDRHASH c)) -mkScriptHash :: forall era. Era era => Int -> SL.ScriptHash era -mkScriptHash = SL.ScriptHash . mkDummyHash (Proxy @(ADDRHASH (Crypto era))) +mkScriptHash :: forall era. ShelleyBasedEra era => Int -> SL.ScriptHash era +mkScriptHash = SL.ScriptHash . mkDummyHash (Proxy @(ADDRHASH (EraCrypto era))) -- | @mkKeyPair'@ from @Test.Shelley.Spec.Ledger.Utils@ doesn't work for real -- crypto: -- mkDSIGNKeyPair :: - forall era kd. DSIGNAlgorithm (DSIGN (Crypto era)) + forall c kd. DSIGNAlgorithm (DSIGN c) => Word8 - -> SL.KeyPair kd era + -> SL.KeyPair kd c mkDSIGNKeyPair byte = SL.KeyPair (SL.VKey $ DSIGN.deriveVerKeyDSIGN sk) sk where seed = Seed.mkSeedFromBytes $ Strict.replicate - (fromIntegral (DSIGN.seedSizeDSIGN (Proxy @(DSIGN (Crypto era))))) + (fromIntegral (DSIGN.seedSizeDSIGN (Proxy @(DSIGN c)))) byte sk = DSIGN.genKeyDSIGN seed mkVRFKeyPair :: - forall era. VRFAlgorithm (VRF (Crypto era)) - => Proxy era + forall c. VRFAlgorithm (VRF c) + => Proxy c -> Word8 - -> (SL.SignKeyVRF era, SL.VerKeyVRF era) + -> (SL.SignKeyVRF c, SL.VerKeyVRF c) mkVRFKeyPair _ byte = (sk, VRF.deriveVerKeyVRF sk) where seed = Seed.mkSeedFromBytes $ Strict.replicate - (fromIntegral (VRF.seedSizeVRF (Proxy @(VRF (Crypto era))))) + (fromIntegral (VRF.seedSizeVRF (Proxy @(VRF c)))) byte sk = VRF.genKeyVRF seed -keyToCredential :: Era era => SL.KeyPair r era -> SL.Credential r era +keyToCredential :: ShelleyBasedEra era => SL.KeyPair r (EraCrypto era) -> SL.Credential r era keyToCredential = SL.KeyHashObj . SL.hashKey . SL.vKey {------------------------------------------------------------------------------- @@ -235,28 +235,28 @@ examples = Golden.Examples { (mkKeyHash 0) (SL.emptyPParamsUpdate {SL._keyDeposit = SJust (SL.Coin 100)}) -examplePoolDistr :: forall era. TPraosCrypto era => SL.PoolDistr era +examplePoolDistr :: forall c. TPraosCrypto c => SL.PoolDistr c examplePoolDistr = SL.PoolDistr $ Map.fromList [ (mkKeyHash 1, SL.IndividualPoolStake 1 - (SL.hashVerKeyVRF (snd (SL.vrf (exampleKeys @era))))) + (SL.hashVerKeyVRF (snd (SL.vrf (exampleKeys @c))))) ] -- | This is not a valid block. We don't care, we are only interested in -- serialisation, not validation. -exampleBlock :: ShelleyBlock StandardShelley +exampleBlock :: forall era. era ~ StandardShelley => ShelleyBlock era exampleBlock = mkShelleyBlock $ SL.Block blockHeader blockBody where - keys :: SL.AllIssuerKeys StandardShelley 'SL.StakePool + keys :: SL.AllIssuerKeys (EraCrypto era) 'SL.StakePool keys = exampleKeys (_, (hotKey, _)) = head $ SL.hot keys SL.KeyPair vKeyCold _ = SL.cold keys - blockHeader :: SL.BHeader StandardShelley + blockHeader :: SL.BHeader (EraCrypto era) blockHeader = SL.BHeader blockHeaderBody (SL.signedKES () 0 blockHeaderBody hotKey) - blockHeaderBody :: SL.BHBody StandardShelley + blockHeaderBody :: SL.BHBody (EraCrypto era) blockHeaderBody = SL.BHBody { bheaderBlockNo = BlockNo 3 , bheaderSlotNo = SlotNo 9 @@ -271,13 +271,13 @@ exampleBlock = mkShelleyBlock $ SL.Block blockHeader blockBody , bprotver = SL.ProtVer 2 0 } - blockBody :: SL.TxSeq StandardShelley + blockBody :: SL.TxSeq era blockBody = SL.TxSeq (StrictSeq.fromList [exampleTx]) mkBytes :: Word8 -> ByteString mkBytes = Strict.replicate - (fromIntegral (VRF.sizeOutputVRF (Proxy @(VRF (Crypto StandardShelley))))) + (fromIntegral (VRF.sizeOutputVRF (Proxy @(VRF (EraCrypto era))))) exampleSerialisedBlock :: Serialised (ShelleyBlock StandardShelley) exampleSerialisedBlock = Serialised "" @@ -329,14 +329,14 @@ exampleTx = SL.Tx txBody witnessSet (SJust metadata) witnessSet :: SL.WitnessSet era witnessSet = mempty { SL.addrWits = - SL.makeWitnessesVKey (SL.hashAnnotated txBody) witnesses + SL.makeWitnessesVKey (SL.eraIndTxBodyHash txBody) witnesses } where - witnesses :: [SL.KeyPair 'SL.Witness era] + witnesses :: [SL.KeyPair 'SL.Witness (EraCrypto era)] witnesses = [ SL.asWitness examplePayKey , SL.asWitness exampleStakeKey - , SL.asWitness $ SL.cold (exampleKeys @era @'SL.StakePool) + , SL.asWitness $ SL.cold (exampleKeys @(EraCrypto era) @'SL.StakePool) ] metadata :: SL.MetaData @@ -370,10 +370,12 @@ exampleAnnTip = AnnTip { , annTipInfo = exampleHeaderHash } -exampleChainDepState :: ChainDepState (BlockProtocol (ShelleyBlock StandardShelley)) +exampleChainDepState :: + forall era. era ~ StandardShelley + => ChainDepState (BlockProtocol (ShelleyBlock era)) exampleChainDepState = TPraosState (NotOrigin 1) (mkPrtclState 1) where - mkPrtclState :: Word64 -> SL.ChainDepState StandardShelley + mkPrtclState :: Word64 -> SL.ChainDepState (EraCrypto era) mkPrtclState seed = SL.ChainDepState { SL.csProtocol = SL.PrtclState (Map.fromList [ @@ -437,9 +439,9 @@ exampleNewEpochState = SL.NewEpochState { rewardUpdate :: SL.RewardUpdate era rewardUpdate = SL.RewardUpdate { deltaT = SL.Coin 10 - , deltaR = SL.Coin 100 + , deltaR = SL.Coin (- 100) , rs = Map.singleton (keyToCredential exampleStakeKey) (SL.Coin 10) - , deltaF = SL.Coin 3 + , deltaF = SL.DeltaCoin (- 3) , nonMyopic = nonMyopic } @@ -470,23 +472,23 @@ exampleExtLedgerState = ExtLedgerState { Keys -------------------------------------------------------------------------------} -examplePayKey :: Era era => SL.KeyPair 'SL.Payment era +examplePayKey :: Crypto c => SL.KeyPair 'SL.Payment c examplePayKey = mkDSIGNKeyPair 0 -exampleStakeKey :: Era era => SL.KeyPair 'SL.Staking era +exampleStakeKey :: Crypto c => SL.KeyPair 'SL.Staking c exampleStakeKey = mkDSIGNKeyPair 1 -exampleKeys :: forall era r. Era era => SL.AllIssuerKeys era r +exampleKeys :: forall c r. Crypto c => SL.AllIssuerKeys c r exampleKeys = SL.AllIssuerKeys coldKey - (mkVRFKeyPair (Proxy @era) 1) + (mkVRFKeyPair (Proxy @c) 1) [(SL.KESPeriod 0, SL.mkKESKeyPair (1, 0, 0, 0, 3))] (SL.hashKey (SL.vKey coldKey)) where coldKey = mkDSIGNKeyPair 1 -examplePoolParams :: forall era. Era era => SL.PoolParams era +examplePoolParams :: forall era. ShelleyBasedEra era => SL.PoolParams era examplePoolParams = SL.PoolParams { _poolPubKey = SL.hashKey $ SL.vKey $ SL.cold poolKeys , _poolVrf = SL.hashVerKeyVRF $ snd $ SL.vrf poolKeys @@ -502,4 +504,4 @@ examplePoolParams = SL.PoolParams { } } where - poolKeys = exampleKeys @era @'SL.StakePool + poolKeys = exampleKeys @(EraCrypto era) @'SL.StakePool diff --git a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs index 532d5cbed7e..6e311aef7a4 100644 --- a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs +++ b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs @@ -37,6 +37,7 @@ import Test.Util.Serialisation.Roundtrip (SomeResult (..), WithVersion (..)) import Test.Consensus.Shelley.MockCrypto (CanMock) +import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes as SL import Test.Shelley.Spec.Ledger.Serialisation.Generators (genPParams) {------------------------------------------------------------------------------- @@ -52,7 +53,7 @@ instance CanMock era => Arbitrary (ShelleyBlock era) where instance CanMock era => Arbitrary (Header (ShelleyBlock era)) where arbitrary = getHeader <$> arbitrary -instance CanMock era => Arbitrary (ShelleyHash era) where +instance SL.Mock c => Arbitrary (ShelleyHash c) where arbitrary = ShelleyHash <$> arbitrary instance CanMock era => Arbitrary (GenTx (ShelleyBlock era)) where @@ -99,7 +100,7 @@ instance CanMock era => Arbitrary (NonMyopicMemberRewards era) where instance CanMock era => Arbitrary (Point (ShelleyBlock era)) where arbitrary = BlockPoint <$> arbitrary <*> arbitrary -instance Era era => Arbitrary (TPraosState era) where +instance TPraosCrypto c => Arbitrary (TPraosState c) where arbitrary = do lastSlot <- frequency [ (1, return Origin) @@ -134,7 +135,8 @@ instance Arbitrary ShelleyNodeToNodeVersion where instance Arbitrary ShelleyNodeToClientVersion where arbitrary = arbitraryBoundedEnum -instance Era era => Arbitrary (SomeBlock (NestedCtxt f) (ShelleyBlock era)) where +instance ShelleyBasedEra era + => Arbitrary (SomeBlock (NestedCtxt f) (ShelleyBlock era)) where arbitrary = return (SomeBlock indexIsTrivial) {------------------------------------------------------------------------------- @@ -145,21 +147,7 @@ instance Arbitrary (SL.PParams' SL.StrictMaybe era) where arbitrary = genericArbitraryU shrink = genericShrink -instance (TPraosCrypto era, CanMock era) => Arbitrary (SL.LedgerView era) where - arbitrary = do - lvProtParams <- genPParams (Proxy @era) - lvPoolDistr <- arbitrary - lvGenDelegs <- arbitrary - pure SL.LedgerView{..} - - shrink lv = - -- TODO shrink for lvProtParams - [ lv{SL.lvPoolDistr = x} | x <- shrink lvPoolDistr ] ++ - [ lv{SL.lvGenDelegs = x} | x <- shrink lvGenDelegs ] - where - SL.LedgerView { lvPoolDistr, lvGenDelegs } = lv - -instance Era era => Arbitrary (SL.ChainDepState era) where +instance TPraosCrypto c => Arbitrary (SL.ChainDepState c) where arbitrary = genericArbitraryU shrink = genericShrink diff --git a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/MockCrypto.hs b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/MockCrypto.hs index 70d612c0967..df260bd9a4e 100644 --- a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/MockCrypto.hs +++ b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/MockCrypto.hs @@ -17,11 +17,12 @@ import Cardano.Crypto.Hash (HashAlgorithm) import Cardano.Crypto.KES (MockKES) import Cardano.Ledger.Crypto (Crypto (..)) -import qualified Cardano.Ledger.Era as Era (Era (Crypto)) -import Cardano.Ledger.Shelley (Shelley) import Test.Cardano.Crypto.VRF.Fake (FakeVRF) -import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes as SL +import qualified Test.Shelley.Spec.Ledger.ConcreteCryptoTypes as SL (Mock) +import qualified Test.Shelley.Spec.Ledger.Utils as SL (ShelleyTest) +import Ouroboros.Consensus.Shelley.Eras (EraCrypto, ShelleyBasedEra, + ShelleyEra) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import Ouroboros.Consensus.Shelley.Protocol.Crypto (TPraosCrypto) @@ -40,11 +41,16 @@ instance HashAlgorithm h => Crypto (MockCrypto h) where type KES (MockCrypto h) = MockKES 10 type VRF (MockCrypto h) = FakeVRF -type MockShelley h = Shelley (MockCrypto h) +type MockShelley h = ShelleyEra (MockCrypto h) -instance HashAlgorithm h => TPraosCrypto (MockShelley h) +instance HashAlgorithm h => TPraosCrypto (MockCrypto h) type Block h = ShelleyBlock (MockShelley h) -- | Cryptography that can easily be mocked -type CanMock era = (Era.Era era, SL.Mock (Era.Crypto era)) +type CanMock era = + ( ShelleyBasedEra era + , SL.Mock (EraCrypto era) + -- TODO #2677 the generators in the ledger impose this constraint + , SL.ShelleyTest era + ) 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 6b94192bc18..057727079ad 100644 --- a/ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs @@ -37,6 +37,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Ratio (denominator, numerator) import qualified Data.Sequence.Strict as Seq +import Data.Set (Set) import qualified Data.Set as Set import Data.Word (Word64) import GHC.Generics (Generic) @@ -44,9 +45,8 @@ import Quiet (Quiet (..)) import Test.QuickCheck -import Cardano.Binary (toCBOR) import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), seedSizeDSIGN) -import Cardano.Crypto.Hash (Hash, HashAlgorithm, hashWithSerialiser) +import Cardano.Crypto.Hash (Hash, HashAlgorithm) import Cardano.Crypto.KES (KESAlgorithm (..)) import Cardano.Crypto.Libsodium.MLockedBytes (mlsbFromByteString) import Cardano.Crypto.Seed (mkSeedFromBytes) @@ -64,8 +64,7 @@ import Test.Util.Orphans.Arbitrary () import Test.Util.Slots (NumSlots (..)) import Test.Util.Time (dawnOfTime) -import Cardano.Ledger.Crypto (DSIGN, KES, VRF) -import Cardano.Ledger.Era (Era (Crypto)) +import Cardano.Ledger.Crypto (Crypto, DSIGN, KES, VRF) import qualified Shelley.Spec.Ledger.API as SL import qualified Shelley.Spec.Ledger.BaseTypes as SL (truncateUnitInterval, unitIntervalFromRational) @@ -74,10 +73,12 @@ import qualified Shelley.Spec.Ledger.OCert as SL (OCertSignable (..)) import qualified Shelley.Spec.Ledger.PParams as SL (emptyPParams, emptyPParamsUpdate) import qualified Shelley.Spec.Ledger.Tx as SL (WitnessSetHKD (..)) +import qualified Shelley.Spec.Ledger.TxBody as SL (eraIndTxBodyHash) +import qualified Shelley.Spec.Ledger.UTxO as SL (makeWitnessesVKey) -import Ouroboros.Consensus.Shelley.Eras (ShelleyEra) -import Ouroboros.Consensus.Shelley.Ledger (GenTx (..), ShelleyBlock, - mkShelleyTx) +import Ouroboros.Consensus.Shelley.Eras (EraCrypto, ShelleyEra) +import Ouroboros.Consensus.Shelley.Ledger (GenTx (..), + ShelleyBasedEra, ShelleyBlock, mkShelleyTx) import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Shelley.Protocol @@ -115,31 +116,31 @@ tpraosSlotLength = slotLengthFromSec 2 CoreNode secrets/etc -------------------------------------------------------------------------------} -data CoreNode era = CoreNode { - cnGenesisKey :: !(SL.SignKeyDSIGN era) - , cnDelegateKey :: !(SL.SignKeyDSIGN era) +data CoreNode c = CoreNode { + cnGenesisKey :: !(SL.SignKeyDSIGN c) + , cnDelegateKey :: !(SL.SignKeyDSIGN c) -- ^ Cold delegate key. The hash of the corresponding verification -- (public) key will be used as the payment credential. - , cnStakingKey :: !(SL.SignKeyDSIGN era) + , cnStakingKey :: !(SL.SignKeyDSIGN c) -- ^ The hash of the corresponding verification (public) key will be -- used as the staking credential. - , cnVRF :: !(SL.SignKeyVRF era) - , cnKES :: !(SL.SignKeyKES era) - , cnOCert :: !(SL.OCert era) + , cnVRF :: !(SL.SignKeyVRF c) + , cnKES :: !(SL.SignKeyKES c) + , cnOCert :: !(SL.OCert c) } -data CoreNodeKeyInfo era = CoreNodeKeyInfo +data CoreNodeKeyInfo c = CoreNodeKeyInfo { cnkiKeyPair - :: ( SL.KeyPair 'SL.Payment era - , SL.KeyPair 'SL.Staking era + :: ( SL.KeyPair 'SL.Payment c + , SL.KeyPair 'SL.Staking c ) , cnkiCoreNode :: - ( SL.KeyPair 'SL.Genesis era - , Gen.AllIssuerKeys era 'SL.GenesisDelegate + ( SL.KeyPair 'SL.Genesis c + , Gen.AllIssuerKeys c 'SL.GenesisDelegate ) } -coreNodeKeys :: CSL.Mock (Crypto era) => CoreNode era -> CoreNodeKeyInfo era +coreNodeKeys :: forall c. CSL.Mock c => CoreNode c -> CoreNodeKeyInfo c coreNodeKeys CoreNode{cnGenesisKey, cnDelegateKey, cnStakingKey} = CoreNodeKeyInfo { cnkiCoreNode = @@ -157,22 +158,23 @@ coreNodeKeys CoreNode{cnGenesisKey, cnDelegateKey, cnStakingKey} = , cnkiKeyPair = (mkDSIGNKeyPair cnDelegateKey, mkDSIGNKeyPair cnStakingKey) } where + mkDSIGNKeyPair :: SL.SignKeyDSIGN c -> SL.KeyPair kd c mkDSIGNKeyPair k = SL.KeyPair (SL.VKey $ deriveVerKeyDSIGN k) k genCoreNode :: - forall era. TPraosCrypto era + forall c. TPraosCrypto c => SL.KESPeriod - -> Gen (CoreNode era) + -> Gen (CoreNode c) genCoreNode startKESPeriod = do - genKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN (Crypto era)))) - delKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN (Crypto era)))) - stkKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN (Crypto era)))) - vrfKey <- genKeyVRF <$> genSeed (seedSizeVRF (Proxy @(VRF (Crypto era)))) + genKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN c))) + delKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN c))) + stkKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN c))) + vrfKey <- genKeyVRF <$> genSeed (seedSizeVRF (Proxy @(VRF c))) kesKey <- genKeyKES . mlsbFromByteString - <$> genBytes (seedSizeKES (Proxy @(KES (Crypto era)))) + <$> genBytes (seedSizeKES (Proxy @(KES c))) let kesPub = deriveVerKeyKES kesKey sigma = SL.signedDSIGN - @era + @c delKey (SL.OCertSignable kesPub certificateIssueNumber startKESPeriod) let ocert = SL.OCert { @@ -198,7 +200,7 @@ genCoreNode startKESPeriod = do genSeed :: Integral a => a -> Gen Cardano.Crypto.Seed genSeed = fmap mkSeedFromBytes . genBytes -mkLeaderCredentials :: TPraosCrypto era => CoreNode era -> TPraosLeaderCredentials era +mkLeaderCredentials :: TPraosCrypto c => CoreNode c -> TPraosLeaderCredentials c mkLeaderCredentials CoreNode { cnDelegateKey, cnVRF, cnKES, cnOCert } = TPraosLeaderCredentials { tpraosLeaderCredentialsInitSignKey = cnKES @@ -227,14 +229,14 @@ data KesConfig = KesConfig -- | A 'KesConfig' that will not require more evolutions than this test's crypto -- allows. mkKesConfig - :: forall proxy era. Era era - => proxy era -> NumSlots -> KesConfig + :: forall proxy c. Crypto c + => proxy c -> NumSlots -> KesConfig mkKesConfig _ (NumSlots t) = KesConfig { maxEvolutions , slotsPerEvolution = divCeiling t maxEvolutions } where - maxEvolutions = fromIntegral $ totalPeriodsKES (Proxy @(KES (Crypto era))) + maxEvolutions = fromIntegral $ totalPeriodsKES (Proxy @(KES c)) -- | Like 'div', but rounds-up. divCeiling :: Integral a => a -> a -> a @@ -263,14 +265,14 @@ mkEpochSize (SecurityParam k) f = -- but we can configure a potentially lower maximum for the ledger, that's why -- we take it as an argument. mkGenesisConfig - :: forall era. TPraosCrypto era + :: forall era. TPraosCrypto (EraCrypto era) => ProtVer -- ^ Initial protocol version -> SecurityParam -> Rational -- ^ Initial active slot coefficient -> DecentralizationParam -> SlotLength -> KesConfig - -> [CoreNode era] + -> [CoreNode (EraCrypto era)] -> ShelleyGenesis era mkGenesisConfig pVer k f d slotLength kesCfg coreNodes = ShelleyGenesis { @@ -311,13 +313,14 @@ mkGenesisConfig pVer k f d slotLength kesCfg coreNodes = , SL._protocolVersion = pVer } - coreNodesToGenesisMapping :: Map (SL.KeyHash 'SL.Genesis era) (SL.GenDelegPair era) + coreNodesToGenesisMapping :: + Map (SL.KeyHash 'SL.Genesis (EraCrypto era)) (SL.GenDelegPair (EraCrypto era)) coreNodesToGenesisMapping = Map.fromList [ let - gkh :: SL.KeyHash 'SL.Genesis era + gkh :: SL.KeyHash 'SL.Genesis (EraCrypto era) gkh = SL.hashKey . SL.VKey $ deriveVerKeyDSIGN cnGenesisKey - gdpair :: SL.GenDelegPair era + gdpair :: SL.GenDelegPair (EraCrypto era) gdpair = SL.GenDelegPair (SL.hashKey . SL.VKey $ deriveVerKeyDSIGN cnDelegateKey) (SL.hashVerKeyVRF $ deriveVerKeyVRF cnVRF) @@ -354,9 +357,10 @@ mkGenesisConfig pVer k f d slotLength kesCfg coreNodes = ] } where - coreNodeToPoolMapping :: Map (SL.KeyHash 'SL.StakePool era) (SL.PoolParams era) - = Map.fromList - [ ( SL.hashKey . SL.VKey . deriveVerKeyDSIGN $ cnStakingKey + coreNodeToPoolMapping :: + Map (SL.KeyHash 'SL.StakePool (EraCrypto era)) (SL.PoolParams era) + coreNodeToPoolMapping = Map.fromList [ + ( SL.hashKey . SL.VKey . deriveVerKeyDSIGN $ cnStakingKey , SL.PoolParams { SL._poolPubKey = poolHash , SL._poolVrf = vrfHash @@ -380,12 +384,12 @@ mkGenesisConfig pVer k f d slotLength kesCfg coreNodes = , let vrfHash = SL.hashVerKeyVRF $ deriveVerKeyVRF cnVRF ] -mkProtocolShelley - :: forall m c. (IOLike m, TPraosCrypto (ShelleyEra c)) +mkProtocolShelley :: + forall m c. (IOLike m, ShelleyBasedEra (ShelleyEra c)) => ShelleyGenesis (ShelleyEra c) -> SL.Nonce -> ProtVer - -> CoreNode (ShelleyEra c) + -> CoreNode c -> ProtocolInfo m (ShelleyBlock (ShelleyEra c)) mkProtocolShelley genesis initialNonce protVer coreNode = protocolInfoShelley $ ProtocolParamsShelley { @@ -401,13 +405,13 @@ mkProtocolShelley genesis initialNonce protVer coreNode = incrementMinorProtVer :: SL.ProtVer -> SL.ProtVer incrementMinorProtVer (SL.ProtVer major minor) = SL.ProtVer major (succ minor) -mkSetDecentralizationParamTxs - :: forall era. (TPraosCrypto era) - => [CoreNode era] +mkSetDecentralizationParamTxs :: + forall c. ShelleyBasedEra (ShelleyEra c) + => [CoreNode c] -> ProtVer -- ^ The proposed protocol version -> SlotNo -- ^ The TTL -> DecentralizationParam -- ^ The new value - -> [GenTx (ShelleyBlock era)] + -> [GenTx (ShelleyBlock (ShelleyEra c))] mkSetDecentralizationParamTxs coreNodes pVer ttl dNew = (:[]) $ mkShelleyTx $ @@ -422,27 +426,28 @@ mkSetDecentralizationParamTxs coreNodes pVer ttl dNew = scheduledEpoch :: EpochNo scheduledEpoch = EpochNo 0 - witnessSet :: SL.WitnessSet era + witnessSet :: SL.WitnessSet (ShelleyEra c) witnessSet = SL.WitnessSet - { addrWits = Set.fromList signatures + { addrWits = signatures , bootWits = Set.empty , msigWits = Map.empty } -- Every node signs the transaction body, since it includes a " vote " from -- every node. - signatures :: [SL.WitVKey era 'SL.Witness] + signatures :: Set (SL.WitVKey 'SL.Witness (ShelleyEra c)) signatures = - [ SL.WitVKey (SL.VKey vk) $ - SL.signedDSIGN @era sk (hashWithSerialiser toCBOR body) - | cn <- coreNodes - , let sk = cnDelegateKey cn - , let vk = deriveVerKeyDSIGN sk - ] + SL.makeWitnessesVKey + (SL.eraIndTxBodyHash body) + [ SL.KeyPair (SL.VKey vk) sk + | cn <- coreNodes + , let sk = cnDelegateKey cn + , let vk = deriveVerKeyDSIGN sk + ] -- Nothing but the parameter update and the obligatory touching of an -- input. - body :: SL.TxBody era + body :: SL.TxBody (ShelleyEra c) body = SL.TxBody { _certs = Seq.empty , _inputs = Set.singleton (fst touchCoins) @@ -459,7 +464,7 @@ mkSetDecentralizationParamTxs coreNodes pVer ttl dNew = -- We use the input of the first node, but we just put it all right back. -- -- ASSUMPTION: This transaction runs in the first slot. - touchCoins :: (SL.TxIn era, SL.TxOut era) + touchCoins :: (SL.TxIn (ShelleyEra c), SL.TxOut (ShelleyEra c)) touchCoins = case coreNodes of [] -> error "no nodes!" cn:_ -> @@ -473,7 +478,7 @@ mkSetDecentralizationParamTxs coreNodes pVer ttl dNew = coin = SL.Coin $ fromIntegral initialLovelacePerCoreNode -- One replicant of the parameter update per each node. - update :: SL.Update era + update :: SL.Update (ShelleyEra c) update = flip SL.Update scheduledEpoch $ SL.ProposedPPUpdates $ Map.fromList $ @@ -497,13 +502,15 @@ mkSetDecentralizationParamTxs coreNodes pVer ttl dNew = initialLovelacePerCoreNode :: Word64 initialLovelacePerCoreNode = 1000 -mkCredential :: TPraosCrypto era => SL.SignKeyDSIGN era -> SL.Credential r era +mkCredential :: + TPraosCrypto (EraCrypto era) + => SL.SignKeyDSIGN (EraCrypto era) -> SL.Credential r era mkCredential = SL.KeyHashObj . mkKeyHash -mkKeyHash :: TPraosCrypto era => SL.SignKeyDSIGN era -> SL.KeyHash r era +mkKeyHash :: TPraosCrypto c => SL.SignKeyDSIGN c -> SL.KeyHash r c mkKeyHash = SL.hashKey . mkVerKey -mkVerKey :: TPraosCrypto era => SL.SignKeyDSIGN era -> SL.VKey r era +mkVerKey :: TPraosCrypto c => SL.SignKeyDSIGN c -> SL.VKey r c mkVerKey = SL.VKey . deriveVerKeyDSIGN mkKeyHashVrf :: (HashAlgorithm h, VRFAlgorithm vrf) diff --git a/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs b/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs index 6b3b7ca60c1..3b117af2cc2 100644 --- a/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs +++ b/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs @@ -34,7 +34,7 @@ import qualified Test.Shelley.Spec.Ledger.Generator.Core as Gen import qualified Test.Shelley.Spec.Ledger.Generator.Presets as Gen.Presets import qualified Test.Shelley.Spec.Ledger.Generator.Utxo as Gen -import Test.Consensus.Shelley.MockCrypto (MockShelley) +import Test.Consensus.Shelley.MockCrypto (MockCrypto, MockShelley) import Test.ThreadNet.Infra.Shelley data ShelleyTxGenExtra h = ShelleyTxGenExtra @@ -123,10 +123,11 @@ genTx _cfg slotNo TickedShelleyLedgerState { tickedShelleyLedgerState } genEnv = data WhetherToGeneratePPUs = DoNotGeneratePPUs | DoGeneratePPUs deriving (Show) -mkGenEnv :: forall h. HashAlgorithm h - => WhetherToGeneratePPUs - -> [CoreNode (MockShelley h)] - -> Gen.GenEnv (MockShelley h) +mkGenEnv :: + forall h. HashAlgorithm h + => WhetherToGeneratePPUs + -> [CoreNode (MockCrypto h)] + -> Gen.GenEnv (MockShelley h) mkGenEnv whetherPPUs coreNodes = Gen.GenEnv keySpace constants where -- Configuration of the transaction generator diff --git a/ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Serialisation.hs b/ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Serialisation.hs index 195479749c2..082f3c56502 100644 --- a/ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Serialisation.hs +++ b/ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Serialisation.hs @@ -54,7 +54,7 @@ tests = testGroup "Shelley" testCodecCfg = ShelleyCodecConfig dictNestedHdr :: - forall a era. Era era + forall a era. ShelleyBasedEra era => NestedCtxt_ (ShelleyBlock era) Header a -> Dict (Eq a, Show a) dictNestedHdr CtxtShelley = Dict diff --git a/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs b/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs index 78e23cecec7..51ff1384a45 100644 --- a/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs +++ b/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs @@ -36,6 +36,7 @@ import qualified Shelley.Spec.Ledger.API as SL import qualified Shelley.Spec.Ledger.BaseTypes as SL (UnitInterval, mkNonceFromNumber, unitIntervalToRational) +import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley import Ouroboros.Consensus.Shelley.Node @@ -208,6 +209,7 @@ prop_simple_real_tpraos_convergence TestSetup , numSlots } = setupTestConfig + testConfigB :: TestConfigB (ShelleyBlock Era) testConfigB = TestConfigB { forgeEbbEnv = Nothing , future = singleEraFuture tpraosSlotLength epochSize @@ -279,7 +281,7 @@ prop_simple_real_tpraos_convergence TestSetup initialKESPeriod :: SL.KESPeriod initialKESPeriod = SL.KESPeriod 0 - coreNodes :: [CoreNode Era] + coreNodes :: [CoreNode (EraCrypto Era)] coreNodes = runGen initSeed $ replicateM (fromIntegral n) $ genCoreNode initialKESPeriod @@ -294,7 +296,7 @@ prop_simple_real_tpraos_convergence TestSetup activeSlotCoeff setupD tpraosSlotLength - (mkKesConfig (Proxy @Era) numSlots) + (mkKesConfig (Proxy @(EraCrypto Era)) numSlots) coreNodes epochSize :: EpochSize diff --git a/ouroboros-consensus-shelley-test/test/golden/disk/ExtLedgerState b/ouroboros-consensus-shelley-test/test/golden/disk/ExtLedgerState index 72b405bc454ed942cf1ae99a070977f334bdbfbd..c416c77f38326cde954b990d3bc8afb5c2c23c79 100644 GIT binary patch delta 30 mcmbQmI*WBf03*9Z%EBgw2$_i|WSN#D2$_i|WSNzk7fjSr*gTz)nGpb%*9l<& diff --git a/ouroboros-consensus-shelley-test/test/golden/disk/LedgerState b/ouroboros-consensus-shelley-test/test/golden/disk/LedgerState index 8986a9d428d802c9ab9b5b323f116f0a6bb7efd5..ac5eab41b329165383e89259abf4fb1214975cfe 100644 GIT binary patch delta 29 lcmdnTypMT903*9Z%EBgw2$_i|WSN#D2$_i|WSNzk7fjSrm^__P9RQS$38(-7 diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs index 84c1ed7a968..cbee5af730f 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.Shelley.Eras ( -- * Eras based on the Shelley ledger ShelleyEra @@ -7,36 +9,40 @@ module Ouroboros.Consensus.Shelley.Eras ( , StandardShelley , StandardAllegra , StandardMary + -- * Shelley-based era + , ShelleyBasedEra + -- * Type synonyms for convenience + , EraCrypto + -- * Re-exports + , StandardCrypto ) where -import qualified Cardano.Ledger.Shelley as Era (Shelley) +import Cardano.Ledger.Era (Crypto) +import Cardano.Ledger.Shelley (ShelleyBased, ShelleyEra) -import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) +import qualified Shelley.Spec.Ledger.API as SL + +import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto, + TPraosCrypto) {------------------------------------------------------------------------------- Eras based on the Shelley ledger -------------------------------------------------------------------------------} --- | The era after Byron is the Shelley era. --- --- The Shelley ledger and block type itself is parameterised by an era --- parameter, which is in its turn parameterised by the crypto used. -type ShelleyEra c = Era.Shelley c - -- | The era after Shelley is Allegra, the illegitimate daughter of Byron. -- -- In this era, we introduce time locks and miscellaneous fixes for the Shelley -- era. -- -- TODO #2668 Change this to the proper Allegra era -type AllegraEra c = Era.Shelley c +type AllegraEra c = ShelleyEra c -- | The era after Allegra is Mary (Shelley), the wife of Percy Shelley. -- -- In this era, we introduce multi-asset (hence MA-ry). -- -- TODO #2668 Change this to the proper Mary era -type MaryEra c = Era.Shelley c +type MaryEra c = ShelleyEra c {------------------------------------------------------------------------------- Eras instantiated with standard crypto @@ -50,3 +56,27 @@ type StandardAllegra = AllegraEra StandardCrypto -- | The Mary era with standard crypto type StandardMary = MaryEra StandardCrypto + +{------------------------------------------------------------------------------- + Shelley-based era +-------------------------------------------------------------------------------} + +-- | Constraints needed by a Shelley-based era +class ( TPraosCrypto (EraCrypto era) + , ShelleyBased era + , SL.ApplyBlock era + , SL.GetLedgerView era + , SL.ApplyTx era + ) => ShelleyBasedEra era + +instance TPraosCrypto c => ShelleyBasedEra (ShelleyEra c) + +{------------------------------------------------------------------------------- + Type synonyms for convenience +-------------------------------------------------------------------------------} + +-- | The 'Cardano.Ledger.Era.Crypto' type family conflicts with the +-- 'Cardano.Ledger.Crypto.Crypto' class. To avoid having to import one or both +-- of them qualified, define 'EraCrypto' as an alias of the former: /return the +-- crypto used by this era/. +type EraCrypto era = Crypto era diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs index 736fe39952a..a460669df3b 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -13,7 +13,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.Shelley.Ledger.Block ( - ShelleyHash (..) + ShelleyBasedEra + , ShelleyHash (..) , ShelleyBlock (..) , mkShelleyBlock , GetHeader (..) @@ -29,8 +30,6 @@ module Ouroboros.Consensus.Shelley.Ledger.Block ( -- * Conversion , fromShelleyPrevHash , toShelleyPrevHash - -- * Re-exported - , Era ) where import Codec.CBOR.Decoding (Decoder) @@ -53,33 +52,33 @@ import Ouroboros.Consensus.Storage.Common (BinaryBlockInfo (..)) import Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE) import Ouroboros.Consensus.Util.Condense +import Cardano.Ledger.Crypto (Crypto, HASH) import qualified Shelley.Spec.Ledger.API as SL -import Cardano.Ledger.Crypto (HASH) -import Cardano.Ledger.Era (Era (Crypto)) +import Ouroboros.Consensus.Shelley.Eras {------------------------------------------------------------------------------- Header hash -------------------------------------------------------------------------------} -newtype ShelleyHash era = ShelleyHash { - unShelleyHash :: SL.HashHeader era +newtype ShelleyHash c = ShelleyHash { + unShelleyHash :: SL.HashHeader c } deriving stock (Eq, Ord, Show, Generic) deriving newtype (ToCBOR, FromCBOR) deriving anyclass (NoThunks) -instance Era era => Serialise (ShelleyHash era) where +instance Crypto c => Serialise (ShelleyHash c) where encode = toCBOR decode = fromCBOR -instance Condense (ShelleyHash era) where +instance Condense (ShelleyHash c) where condense = show . unShelleyHash -instance Era era => ConvertRawHash (ShelleyBlock era) where +instance ShelleyBasedEra era => ConvertRawHash (ShelleyBlock era) where toShortRawHash _ = Crypto.hashToBytesShort . SL.unHashHeader . unShelleyHash fromShortRawHash _ = ShelleyHash . SL.HashHeader . hashFromBytesShortE - hashSize _ = fromIntegral $ Crypto.sizeHash (Proxy @(HASH (Crypto era))) + hashSize _ = fromIntegral $ Crypto.sizeHash (Proxy @(HASH (EraCrypto era))) {------------------------------------------------------------------------------- Shelley blocks and headers @@ -92,29 +91,35 @@ instance Era era => ConvertRawHash (ShelleyBlock era) where -- but we may need different additional information when running the chain. data ShelleyBlock era = ShelleyBlock { shelleyBlockRaw :: !(SL.Block era) - , shelleyBlockHeaderHash :: !(ShelleyHash era) + , shelleyBlockHeaderHash :: !(ShelleyHash (EraCrypto era)) } - deriving (Eq, Show) + +deriving instance ShelleyBasedEra era => Show (ShelleyBlock era) +deriving instance ShelleyBasedEra era => Eq (ShelleyBlock era) instance Typeable era => ShowProxy (ShelleyBlock era) where -type instance HeaderHash (ShelleyBlock era) = ShelleyHash era +type instance HeaderHash (ShelleyBlock era) = ShelleyHash (EraCrypto era) -mkShelleyBlock :: Era era => SL.Block era -> ShelleyBlock era +mkShelleyBlock :: ShelleyBasedEra era => SL.Block era -> ShelleyBlock era mkShelleyBlock raw = ShelleyBlock { shelleyBlockRaw = raw , shelleyBlockHeaderHash = ShelleyHash (SL.bhHash (SL.bheader raw)) } data instance Header (ShelleyBlock era) = ShelleyHeader { - shelleyHeaderRaw :: !(SL.BHeader era) - , shelleyHeaderHash :: !(ShelleyHash era) + shelleyHeaderRaw :: !(SL.BHeader (EraCrypto era)) + , shelleyHeaderHash :: !(ShelleyHash (EraCrypto era)) } - deriving (Eq, Generic, Show, NoThunks) + deriving (Generic) + +deriving instance ShelleyBasedEra era => Show (Header (ShelleyBlock era)) +deriving instance ShelleyBasedEra era => Eq (Header (ShelleyBlock era)) +deriving instance ShelleyBasedEra era => NoThunks (Header (ShelleyBlock era)) instance Typeable era => ShowProxy (Header (ShelleyBlock era)) where -instance Era era => GetHeader (ShelleyBlock era) where +instance ShelleyBasedEra era => GetHeader (ShelleyBlock era) where getHeader (ShelleyBlock rawBlk hdrHash) = ShelleyHeader { shelleyHeaderRaw = SL.bheader rawBlk , shelleyHeaderHash = hdrHash @@ -130,35 +135,37 @@ instance Era era => GetHeader (ShelleyBlock era) where headerIsEBB = const Nothing -mkShelleyHeader :: Era era => SL.BHeader era -> Header (ShelleyBlock era) +mkShelleyHeader :: + ShelleyBasedEra era + => SL.BHeader (EraCrypto era) -> Header (ShelleyBlock era) mkShelleyHeader raw = ShelleyHeader { shelleyHeaderRaw = raw , shelleyHeaderHash = ShelleyHash (SL.bhHash raw) } -instance Era era => HasHeader (ShelleyBlock era) where +instance ShelleyBasedEra era => HasHeader (ShelleyBlock era) where getHeaderFields = getBlockHeaderFields -instance Era era => HasHeader (Header (ShelleyBlock era)) where +instance ShelleyBasedEra era => HasHeader (Header (ShelleyBlock era)) where getHeaderFields hdr = HeaderFields { headerFieldHash = shelleyHeaderHash hdr , headerFieldSlot = SL.bheaderSlotNo . SL.bhbody . shelleyHeaderRaw $ hdr , headerFieldBlockNo = coerce . SL.bheaderBlockNo . SL.bhbody . shelleyHeaderRaw $ hdr } -instance Era era => GetPrevHash (ShelleyBlock era) where +instance ShelleyBasedEra era => GetPrevHash (ShelleyBlock era) where headerPrevHash = fromShelleyPrevHash . SL.bheaderPrev . SL.bhbody . shelleyHeaderRaw -instance Era era => Measured BlockMeasure (ShelleyBlock era) where +instance ShelleyBasedEra era => Measured BlockMeasure (ShelleyBlock era) where measure = blockMeasure -instance Era era => StandardHash (ShelleyBlock era) +instance ShelleyBasedEra era => StandardHash (ShelleyBlock era) -instance Era era => HasAnnTip (ShelleyBlock era) +instance ShelleyBasedEra era => HasAnnTip (ShelleyBlock era) -- The 'ValidateEnvelope' instance lives in the -- "Ouroboros.Consensus.Shelley.Ledger.Ledger" module because of the @@ -169,12 +176,12 @@ instance Era era => HasAnnTip (ShelleyBlock era) -------------------------------------------------------------------------------} -- | From @cardano-ledger-specs@ to @ouroboros-consensus@ -fromShelleyPrevHash :: SL.PrevHash era -> ChainHash (ShelleyBlock era) +fromShelleyPrevHash :: SL.PrevHash (EraCrypto era) -> ChainHash (ShelleyBlock era) fromShelleyPrevHash SL.GenesisHash = GenesisHash fromShelleyPrevHash (SL.BlockHash h) = BlockHash (ShelleyHash h) -- | From @ouroboros-consensus@ to @cardano-ledger-specs@ -toShelleyPrevHash :: ChainHash (Header (ShelleyBlock era)) -> SL.PrevHash era +toShelleyPrevHash :: ChainHash (Header (ShelleyBlock era)) -> SL.PrevHash (EraCrypto era) toShelleyPrevHash GenesisHash = SL.GenesisHash toShelleyPrevHash (BlockHash (ShelleyHash h)) = SL.BlockHash h @@ -199,27 +206,27 @@ instance HasNestedContent f (ShelleyBlock era) Serialisation -------------------------------------------------------------------------------} -instance Era era => ToCBOR (ShelleyBlock era) where +instance ShelleyBasedEra era => ToCBOR (ShelleyBlock era) where -- Don't encode the header hash, we recompute it during deserialisation toCBOR = toCBOR . shelleyBlockRaw -instance Era era => FromCBOR (Annotator (ShelleyBlock era)) where +instance ShelleyBasedEra era => FromCBOR (Annotator (ShelleyBlock era)) where fromCBOR = fmap mkShelleyBlock <$> fromCBOR -instance Era era => ToCBOR (Header (ShelleyBlock era)) where +instance ShelleyBasedEra era => ToCBOR (Header (ShelleyBlock era)) where -- Don't encode the header hash, we recompute it during deserialisation toCBOR = toCBOR . shelleyHeaderRaw -instance Era era => FromCBOR (Annotator (Header (ShelleyBlock era))) where +instance ShelleyBasedEra era => FromCBOR (Annotator (Header (ShelleyBlock era))) where fromCBOR = fmap mkShelleyHeader <$> fromCBOR -encodeShelleyBlock :: Era era => ShelleyBlock era -> Encoding +encodeShelleyBlock :: ShelleyBasedEra era => ShelleyBlock era -> Encoding encodeShelleyBlock = toCBOR -decodeShelleyBlock :: Era era => Decoder s (Lazy.ByteString -> ShelleyBlock era) +decodeShelleyBlock :: ShelleyBasedEra era => Decoder s (Lazy.ByteString -> ShelleyBlock era) decodeShelleyBlock = (. Full) . runAnnotator <$> fromCBOR -shelleyBinaryBlockInfo :: Era era => ShelleyBlock era -> BinaryBlockInfo +shelleyBinaryBlockInfo :: ShelleyBasedEra era => ShelleyBlock era -> BinaryBlockInfo shelleyBinaryBlockInfo blk = BinaryBlockInfo { -- Drop the 'encodeListLen' that precedes the header and the body (= tx -- seq) @@ -228,18 +235,18 @@ shelleyBinaryBlockInfo blk = BinaryBlockInfo { , headerSize = fromIntegral $ Lazy.length (serialize (getHeader blk)) } -encodeShelleyHeader :: Era era => Header (ShelleyBlock era) -> Encoding +encodeShelleyHeader :: ShelleyBasedEra era => Header (ShelleyBlock era) -> Encoding encodeShelleyHeader = toCBOR -decodeShelleyHeader :: Era era => Decoder s (Lazy.ByteString -> Header (ShelleyBlock era)) +decodeShelleyHeader :: ShelleyBasedEra era => Decoder s (Lazy.ByteString -> Header (ShelleyBlock era)) decodeShelleyHeader = (. Full) . runAnnotator <$> fromCBOR {------------------------------------------------------------------------------- Condense -------------------------------------------------------------------------------} -instance Era era => Condense (ShelleyBlock era) where +instance ShelleyBasedEra era => Condense (ShelleyBlock era) where condense = show . shelleyBlockRaw -instance Era era => Condense (Header (ShelleyBlock era)) where +instance ShelleyBasedEra era => Condense (Header (ShelleyBlock era)) where condense = show . shelleyHeaderRaw diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Config.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Config.hs index db7023ef0cf..77e5bc4dab1 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Config.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Config.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Shelley.Ledger.Config ( BlockConfig (..) @@ -25,6 +27,7 @@ import Ouroboros.Consensus.Config import qualified Shelley.Spec.Ledger.API as SL +import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger.Block {------------------------------------------------------------------------------- @@ -44,17 +47,19 @@ data instance BlockConfig (ShelleyBlock era) = ShelleyConfig { -- corresponding to the node's signing key(s), to make sure we prefer -- self-issued blocks. For non block producing nodes, this can be set to -- the empty map. - , shelleyBlockIssuerVKeys :: !(Map (SL.KeyHash 'SL.BlockIssuer era) - (SL.VKey 'SL.BlockIssuer era)) + , shelleyBlockIssuerVKeys :: !(Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era)) + (SL.VKey 'SL.BlockIssuer (EraCrypto era))) } - deriving stock (Show, Generic) - deriving anyclass NoThunks + deriving stock (Generic) + +deriving instance ShelleyBasedEra era => Show (BlockConfig (ShelleyBlock era)) +deriving instance ShelleyBasedEra era => NoThunks (BlockConfig (ShelleyBlock era)) mkShelleyBlockConfig :: - (Era era) + ShelleyBasedEra era => SL.ProtVer -> SL.ShelleyGenesis era - -> [SL.VKey 'SL.BlockIssuer era] + -> [SL.VKey 'SL.BlockIssuer (EraCrypto era)] -> BlockConfig (ShelleyBlock era) mkShelleyBlockConfig protVer genesis blockIssuerVKeys = ShelleyConfig { shelleyProtocolVersion = protVer 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 1720feae6af..e6b1db30450 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -27,6 +28,7 @@ import Ouroboros.Consensus.Util.Assert import qualified Shelley.Spec.Ledger.BlockChain as SL +import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config import Ouroboros.Consensus.Shelley.Ledger.Integrity @@ -38,16 +40,16 @@ import Ouroboros.Consensus.Shelley.Protocol.HotKey (HotKey) Forging -------------------------------------------------------------------------------} -forgeShelleyBlock - :: (TPraosCrypto era, Monad m) - => HotKey era m - -> TPraosCanBeLeader era +forgeShelleyBlock :: + forall m era. (ShelleyBasedEra era, Monad m) + => HotKey (EraCrypto era) m + -> TPraosCanBeLeader (EraCrypto era) -> TopLevelConfig (ShelleyBlock era) - -> BlockNo -- ^ Current block number - -> SlotNo -- ^ Current slot number + -> BlockNo -- ^ Current block number + -> SlotNo -- ^ Current slot number -> TickedLedgerState (ShelleyBlock era) -- ^ Current ledger -> [GenTx (ShelleyBlock era)] -- ^ Txs to add in the block - -> TPraosIsLeader era -- ^ Leader proof + -> TPraosIsLeader (EraCrypto era) -- ^ Leader proof -> m (ShelleyBlock era) forgeShelleyBlock hotKey canBeLeader cfg curNo curSlot tickedLedger txs isLeader = do tpraosFields <- forgeTPraosFields hotKey canBeLeader isLeader mkBhBody @@ -65,8 +67,9 @@ forgeShelleyBlock hotKey canBeLeader cfg curNo curSlot tickedLedger txs isLeader mkHeader TPraosFields { tpraosSignature, tpraosToSign } = SL.BHeader tpraosToSign tpraosSignature + prevHash :: SL.PrevHash (EraCrypto era) prevHash = - toShelleyPrevHash + toShelleyPrevHash @era . castHash . getTipHash $ tickedLedger diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs index ef4137362cf..05fcd642ecf 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs @@ -32,12 +32,13 @@ import Shelley.Spec.Ledger.BaseTypes (strictMaybeToMaybe) import qualified Shelley.Spec.Ledger.LedgerState as SL (proposals) import qualified Shelley.Spec.Ledger.PParams as SL (PParamsUpdate) +import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger data ProtocolUpdate era = ProtocolUpdate { protocolUpdateProposal :: UpdateProposal era - , protocolUpdateState :: UpdateState era + , protocolUpdateState :: UpdateState (EraCrypto era) } deriving (Show, Eq) @@ -86,9 +87,9 @@ data UpdateProposal era = UpdateProposal { -- 4. The next epoch is always started with a clean slate, proposals from the -- previous epoch that didn't make it are discarded (except for "future -- proposals" that are explicitly marked for future epochs). -data UpdateState era = UpdateState { +data UpdateState c = UpdateState { -- | The genesis delegates that voted for this proposal - proposalVotes :: [SL.KeyHash 'SL.Genesis era] + proposalVotes :: [SL.KeyHash 'SL.Genesis c] -- | Has this proposal reached sufficient votes to be adopted? , proposalReachedQuorum :: Bool @@ -116,14 +117,14 @@ protocolUpdates genesis st = [ | (proposal, votes) <- proposalsInv ] where - proposalsInv :: [(SL.PParamsUpdate era, [SL.KeyHash 'SL.Genesis era])] + proposalsInv :: [(SL.PParamsUpdate era, [SL.KeyHash 'SL.Genesis (EraCrypto era)])] proposalsInv = groupSplit id . sortBy (comparing fst) $ map swap (Map.toList proposals) -- Updated proposed within the proposal window - proposals :: Map (SL.KeyHash 'SL.Genesis era) (SL.PParamsUpdate era) + proposals :: Map (SL.KeyHash 'SL.Genesis (EraCrypto era)) (SL.PParamsUpdate era) SL.ProposedPPUpdates proposals = SL.proposals . SL._ppups diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Integrity.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Integrity.hs index a09de4e8684..750ac9a9029 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Integrity.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Integrity.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.Shelley.Ledger.Integrity ( verifyHeaderIntegrity , verifyBlockIntegrity @@ -14,11 +16,10 @@ import qualified Shelley.Spec.Ledger.API as SL import qualified Shelley.Spec.Ledger.Keys as SL (verifySignedKES) import Ouroboros.Consensus.Shelley.Ledger.Block -import Ouroboros.Consensus.Shelley.Protocol -- | Verify whether a header is not corrupted -verifyHeaderIntegrity - :: TPraosCrypto era +verifyHeaderIntegrity :: + ShelleyBasedEra era => Word64 -- ^ 'tpraosSlotsPerKESPeriod' -> Header (ShelleyBlock era) -> Bool @@ -41,8 +42,8 @@ verifyHeaderIntegrity slotsPerKESPeriod hdr@ShelleyHeader { shelleyHeaderRaw } = -- | Verifies whether the block is not corrupted by checking its signature and -- witnesses -verifyBlockIntegrity - :: TPraosCrypto era +verifyBlockIntegrity :: + ShelleyBasedEra era => Word64 -- ^ 'tpraosSlotsPerKESPeriod' -> ShelleyBlock era -> Bool verifyBlockIntegrity slotsPerKESPeriod blk = 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 cb09d7db636..5f7e8cb6f99 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -16,10 +16,12 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Shelley.Ledger.Ledger ( ShelleyLedgerError (..) + , ShelleyBasedEra , ShelleyTip (..) , shelleyTipToPoint , ShelleyTransition(..) @@ -90,24 +92,26 @@ import Ouroboros.Consensus.Util.Versioned import qualified Shelley.Spec.Ledger.API as SL import qualified Shelley.Spec.Ledger.LedgerState as SL (RewardAccounts, proposals) -import qualified Shelley.Spec.Ledger.STS.Chain as SL (ChainPredicateFailure) +import qualified Shelley.Spec.Ledger.STS.Chain as SL (PredicateFailure) +import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.TPraos () import Ouroboros.Consensus.Shelley.Protocol (MaxMajorProtVer (..), - TPraosCrypto, Ticked (TickedPraosLedgerView)) + Ticked (TickedPraosLedgerView)) import Ouroboros.Consensus.Shelley.Protocol.Util (isNewEpoch) {------------------------------------------------------------------------------- Ledger errors -------------------------------------------------------------------------------} -data ShelleyLedgerError era - = TickError !(SL.TickTransitionError era) - | BBodyError !(SL.BlockTransitionError era) - deriving (Eq, Generic, Show) +newtype ShelleyLedgerError era = BBodyError (SL.BlockTransitionError era) + deriving (Generic) -instance Era era => NoThunks (ShelleyLedgerError era) +deriving instance ShelleyBasedEra era => Eq (ShelleyLedgerError era) +deriving instance ShelleyBasedEra era => Show (ShelleyLedgerError era) + +instance ShelleyBasedEra era => NoThunks (ShelleyLedgerError era) {------------------------------------------------------------------------------- Config @@ -177,10 +181,13 @@ shelleyTipToPoint (NotOrigin tip) = BlockPoint (shelleyTipSlotNo tip) data instance LedgerState (ShelleyBlock era) = ShelleyLedgerState { shelleyLedgerTip :: !(WithOrigin (ShelleyTip era)) - , shelleyLedgerState :: !(SL.ShelleyState era) + , shelleyLedgerState :: !(SL.NewEpochState era) , shelleyLedgerTransition :: !ShelleyTransition } - deriving (Eq, Show, Generic, NoThunks) + deriving (Generic, NoThunks) + +deriving instance ShelleyBasedEra era => Show (LedgerState (ShelleyBlock era)) +deriving instance ShelleyBasedEra era => Eq (LedgerState (ShelleyBlock era)) -- | Information required to determine the hard fork point from Shelley to the -- next ledger @@ -209,7 +216,7 @@ newtype ShelleyTransition = ShelleyTransitionInfo { shelleyLedgerTipPoint :: LedgerState (ShelleyBlock era) -> Point (ShelleyBlock era) shelleyLedgerTipPoint = shelleyTipToPoint . shelleyLedgerTip -instance TPraosCrypto era => UpdateLedger (ShelleyBlock era) +instance ShelleyBasedEra era => UpdateLedger (ShelleyBlock era) {------------------------------------------------------------------------------- GetTip @@ -234,7 +241,7 @@ data instance Ticked (LedgerState (ShelleyBlock era)) = TickedShelleyLedgerState -- 2. However, we count within an epoch, which is slot-based. So the count -- must be reset when /ticking/, not when applying a block. , tickedShelleyLedgerTransition :: !ShelleyTransition - , tickedShelleyLedgerState :: !(SL.ShelleyState era) + , tickedShelleyLedgerState :: !(SL.NewEpochState era) } deriving (Generic, NoThunks) @@ -243,7 +250,7 @@ untickedShelleyLedgerTipPoint :: -> Point (ShelleyBlock era) untickedShelleyLedgerTipPoint = shelleyTipToPoint . untickedShelleyLedgerTip -instance Era era => IsLedger (LedgerState (ShelleyBlock era)) where +instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock era)) where type LedgerErr (LedgerState (ShelleyBlock era)) = ShelleyLedgerError era applyChainTick cfg slotNo ShelleyLedgerState{ @@ -261,7 +268,7 @@ instance Era era => IsLedger (LedgerState (ShelleyBlock era)) where else shelleyLedgerTransition , tickedShelleyLedgerState = - SL.applyTickTransition + SL.applyTick globals shelleyLedgerState slotNo @@ -272,7 +279,7 @@ instance Era era => IsLedger (LedgerState (ShelleyBlock era)) where ei :: EpochInfo Identity ei = SL.epochInfo globals -instance TPraosCrypto era +instance ShelleyBasedEra era => ApplyBlock (LedgerState (ShelleyBlock era)) (ShelleyBlock era) where -- Note: in the Shelley ledger, the @CHAIN@ rule is used to apply a whole -- block. In consensus, we split up the application of a block to the ledger @@ -287,16 +294,16 @@ instance TPraosCrypto era applyLedgerBlock = applyHelper $ -- Apply the BBODY transition using the ticked state - withExcept BBodyError ..: SL.applyBlockTransition + withExcept BBodyError ..: SL.applyBlock reapplyLedgerBlock = runIdentity ...: applyHelper $ -- Reapply the BBODY transition using the ticked state - Identity ..: SL.reapplyBlockTransition + Identity ..: SL.reapplyBlock applyHelper :: - (TPraosCrypto era, Monad m) - => (SL.Globals -> SL.ShelleyState era -> SL.Block era -> m (SL.ShelleyState era)) + (ShelleyBasedEra era, Monad m) + => (SL.Globals -> SL.NewEpochState era -> SL.Block era -> m (SL.NewEpochState era)) -> LedgerConfig (ShelleyBlock era) -> ShelleyBlock era -> Ticked (LedgerState (ShelleyBlock era)) @@ -305,7 +312,7 @@ applyHelper f cfg blk TickedShelleyLedgerState{ tickedShelleyLedgerTransition , tickedShelleyLedgerState } = do - newShelleyState <- f globals tickedShelleyLedgerState (shelleyBlockRaw blk) + newNewEpochState <- f globals tickedShelleyLedgerState (shelleyBlockRaw blk) return ShelleyLedgerState { shelleyLedgerTip = NotOrigin ShelleyTip { @@ -314,7 +321,7 @@ applyHelper f cfg blk TickedShelleyLedgerState{ , shelleyTipHash = blockHash blk } , shelleyLedgerState = - newShelleyState + newNewEpochState , shelleyLedgerTransition = ShelleyTransitionInfo { shelleyAfterVoting = -- We count the number of blocks that have been applied after the @@ -343,7 +350,8 @@ applyHelper f cfg blk TickedShelleyLedgerState{ votingDeadline :: SlotNo votingDeadline = subSlots (2 * swindow) startOfNextEpoch -instance TPraosCrypto era => LedgerSupportsProtocol (ShelleyBlock era) where +instance ShelleyBasedEra era + => LedgerSupportsProtocol (ShelleyBlock era) where protocolLedgerView _cfg = TickedPraosLedgerView . SL.currentLedgerView . tickedShelleyLedgerState @@ -367,7 +375,7 @@ instance TPraosCrypto era => LedgerSupportsProtocol (ShelleyBlock era) where -- | 'SL.futureLedgerView' imposes its own bounds. Those bounds could -- /exceed/ the 'maxFor' we have computed, but should never be /less/. - futureLedgerView :: SlotNo -> Ticked (SL.LedgerView era) + futureLedgerView :: SlotNo -> Ticked (SL.LedgerView (EraCrypto era)) futureLedgerView = either (\e -> error ("futureLedgerView failed: " <> show e)) @@ -390,14 +398,16 @@ instance HasHardForkHistory (ShelleyBlock era) where newtype NonMyopicMemberRewards era = NonMyopicMemberRewards { unNonMyopicMemberRewards :: Map (Either SL.Coin (SL.Credential 'SL.Staking era)) - (Map (SL.KeyHash 'SL.StakePool era) SL.Coin) + (Map (SL.KeyHash 'SL.StakePool (EraCrypto era)) SL.Coin) } deriving stock (Show) deriving newtype (Eq) -type Delegations era = Map (SL.Credential 'SL.Staking era) (SL.KeyHash 'SL.StakePool era) +type Delegations era = + Map (SL.Credential 'SL.Staking era) + (SL.KeyHash 'SL.StakePool (EraCrypto era)) -instance Era era => Serialise (NonMyopicMemberRewards era) where +instance ShelleyBasedEra era => Serialise (NonMyopicMemberRewards era) where encode = toCBOR . unNonMyopicMemberRewards decode = NonMyopicMemberRewards <$> fromCBOR @@ -420,7 +430,7 @@ data instance Query (ShelleyBlock era) :: Type -> Type where -- an endpoint that provides all the information that the wallet wants about -- pools, in an extensible fashion. GetStakeDistribution - :: Query (ShelleyBlock era) (SL.PoolDistr era) + :: Query (ShelleyBlock era) (SL.PoolDistr (EraCrypto era)) GetFilteredUTxO :: Set (SL.Addr era) -> Query (ShelleyBlock era) (SL.UTxO era) @@ -456,7 +466,7 @@ data instance Query (ShelleyBlock era) :: Type -> Type where instance Typeable era => ShowProxy (Query (ShelleyBlock era)) where -instance TPraosCrypto era => QueryLedger (ShelleyBlock era) where +instance ShelleyBasedEra era => QueryLedger (ShelleyBlock era) where answerQuery cfg query st = case query of GetLedgerTip -> shelleyLedgerTipPoint st GetEpochNo -> SL.nesEL $ shelleyLedgerState st @@ -536,7 +546,7 @@ instance SameDepIndex (Query (ShelleyBlock era)) where deriving instance Eq (Query (ShelleyBlock era) result) deriving instance Show (Query (ShelleyBlock era) result) -instance Era era => ShowQuery (Query (ShelleyBlock era)) where +instance ShelleyBasedEra era => ShowQuery (Query (ShelleyBlock era)) where showResult GetLedgerTip = show showResult GetEpochNo = show showResult (GetNonMyopicMemberRewards {}) = show @@ -549,7 +559,8 @@ instance Era era => ShowQuery (Query (ShelleyBlock era)) where showResult (GetCBOR {}) = show showResult (GetFilteredDelegationsAndRewardAccounts {}) = show -instance TPraosCrypto era => CommonProtocolParams (ShelleyBlock era) where +instance ShelleyBasedEra era + => CommonProtocolParams (ShelleyBlock era) where maxHeaderSize = fromIntegral . SL._maxBHSize . getPParams . shelleyLedgerState maxTxSize = fromIntegral . SL._maxTxSize . getPParams . shelleyLedgerState @@ -557,38 +568,37 @@ instance TPraosCrypto era => CommonProtocolParams (ShelleyBlock era) where ValidateEnvelope -------------------------------------------------------------------------------} -instance Era era => BasicEnvelopeValidation (ShelleyBlock era) where +instance ShelleyBasedEra era => BasicEnvelopeValidation (ShelleyBlock era) where -- defaults all OK -instance Era era => ValidateEnvelope (ShelleyBlock era) where +instance ShelleyBasedEra era => ValidateEnvelope (ShelleyBlock era) where type OtherHeaderEnvelopeError (ShelleyBlock era) = - SL.ChainPredicateFailure era + SL.PredicateFailure (SL.CHAIN era) additionalEnvelopeChecks cfg (TickedPraosLedgerView ledgerView) hdr = - SL.chainChecks globals pparams (shelleyHeaderRaw hdr) + SL.chainChecks globals (SL.lvChainChecks ledgerView) (shelleyHeaderRaw hdr) where - pparams = SL.lvProtParams ledgerView globals = shelleyLedgerGlobals (configLedger cfg) {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} -getPParams :: SL.ShelleyState era -> SL.PParams era +getPParams :: SL.NewEpochState era -> SL.PParams era getPParams = SL.esPp . SL.nesEs -getProposedPPUpdates :: SL.ShelleyState era -> SL.ProposedPPUpdates era +getProposedPPUpdates :: SL.NewEpochState era -> SL.ProposedPPUpdates era getProposedPPUpdates = SL.proposals . SL._ppups . SL._utxoState . SL.esLState . SL.nesEs -- Get the current EpochState. This is mainly for debugging. -getCurrentEpochState :: SL.ShelleyState era -> SL.EpochState era +getCurrentEpochState :: SL.NewEpochState era -> SL.EpochState era getCurrentEpochState = SL.nesEs -getDState :: SL.ShelleyState era -> SL.DState era +getDState :: SL.NewEpochState era -> SL.DState era getDState = SL._dstate . SL._delegationState . SL.esLState . SL.nesEs -getFilteredDelegationsAndRewardAccounts :: SL.ShelleyState era +getFilteredDelegationsAndRewardAccounts :: SL.NewEpochState era -> Set (SL.Credential 'SL.Staking era) -> (Delegations era, SL.RewardAccounts era) getFilteredDelegationsAndRewardAccounts ss creds = @@ -613,20 +623,25 @@ getFilteredDelegationsAndRewardAccounts ss creds = serialisationFormatVersion2 :: VersionNumber serialisationFormatVersion2 = 2 -encodeShelleyAnnTip :: Era era => AnnTip (ShelleyBlock era) -> Encoding +encodeShelleyAnnTip :: + ShelleyBasedEra era + => AnnTip (ShelleyBlock era) -> Encoding encodeShelleyAnnTip = defaultEncodeAnnTip toCBOR -decodeShelleyAnnTip :: Era era => Decoder s (AnnTip (ShelleyBlock era)) +decodeShelleyAnnTip :: + ShelleyBasedEra era + => Decoder s (AnnTip (ShelleyBlock era)) decodeShelleyAnnTip = defaultDecodeAnnTip fromCBOR -encodeShelleyHeaderState :: Era era - => HeaderState (ShelleyBlock era) - -> Encoding +encodeShelleyHeaderState :: + ShelleyBasedEra era + => HeaderState (ShelleyBlock era) + -> Encoding encodeShelleyHeaderState = encodeHeaderState encode encodeShelleyAnnTip -encodeShelleyTip :: Era era => ShelleyTip era -> Encoding +encodeShelleyTip :: ShelleyBasedEra era => ShelleyTip era -> Encoding encodeShelleyTip ShelleyTip { shelleyTipSlotNo , shelleyTipBlockNo @@ -638,7 +653,7 @@ encodeShelleyTip ShelleyTip { , encode shelleyTipHash ] -decodeShelleyTip :: Era era => Decoder s (ShelleyTip era) +decodeShelleyTip :: ShelleyBasedEra era => Decoder s (ShelleyTip era) decodeShelleyTip = do enforceSize "ShelleyTip" 3 shelleyTipSlotNo <- decode @@ -660,7 +675,10 @@ decodeShelleyTransition = do shelleyAfterVoting <- CBOR.decodeWord32 return ShelleyTransitionInfo{shelleyAfterVoting} -encodeShelleyLedgerState :: Era era => LedgerState (ShelleyBlock era) -> Encoding +encodeShelleyLedgerState :: + ShelleyBasedEra era + => LedgerState (ShelleyBlock era) + -> Encoding encodeShelleyLedgerState ShelleyLedgerState { shelleyLedgerTip , shelleyLedgerState @@ -674,7 +692,7 @@ encodeShelleyLedgerState ] decodeShelleyLedgerState :: - forall era s. Era era + forall era s. ShelleyBasedEra era => Decoder s (LedgerState (ShelleyBlock era)) decodeShelleyLedgerState = decodeVersion [ (serialisationFormatVersion2, Decode decodeShelleyLedgerState2) @@ -692,7 +710,9 @@ decodeShelleyLedgerState = decodeVersion [ , shelleyLedgerTransition } -encodeShelleyQuery :: Era era => Query (ShelleyBlock era) result -> Encoding +encodeShelleyQuery :: + ShelleyBasedEra era + => Query (ShelleyBlock era) result -> Encoding encodeShelleyQuery query = case query of GetLedgerTip -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 0 @@ -717,7 +737,9 @@ encodeShelleyQuery query = case query of GetFilteredDelegationsAndRewardAccounts creds -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 10 <> toCBOR creds -decodeShelleyQuery :: Era era => Decoder s (SomeBlock Query (ShelleyBlock era)) +decodeShelleyQuery :: + ShelleyBasedEra era + => Decoder s (SomeBlock Query (ShelleyBlock era)) decodeShelleyQuery = do len <- CBOR.decodeListLen tag <- CBOR.decodeWord8 @@ -737,8 +759,8 @@ decodeShelleyQuery = do "decodeShelleyQuery: invalid (len, tag): (" <> show len <> ", " <> show tag <> ")" -encodeShelleyResult - :: Era era +encodeShelleyResult :: + ShelleyBasedEra era => Query (ShelleyBlock era) result -> result -> Encoding encodeShelleyResult query = case query of GetLedgerTip -> encodePoint encode @@ -753,8 +775,8 @@ encodeShelleyResult query = case query of GetCBOR {} -> encode GetFilteredDelegationsAndRewardAccounts {} -> toCBOR -decodeShelleyResult - :: Era era +decodeShelleyResult :: + ShelleyBasedEra era => Query (ShelleyBlock era) result -> forall s. Decoder s result decodeShelleyResult query = case query of diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 982ebb3527a..e0494cc58dc 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -8,6 +8,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -46,14 +47,15 @@ import qualified Shelley.Spec.Ledger.UTxO as SL (txid) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger -import Ouroboros.Consensus.Shelley.Protocol - type ShelleyTxId era = SL.TxId era data instance GenTx (ShelleyBlock era) = ShelleyTx !(ShelleyTxId era) !(SL.Tx era) - deriving stock (Eq, Generic) - deriving anyclass (NoThunks) + deriving stock (Generic) + +deriving instance ShelleyBasedEra era => NoThunks (GenTx (ShelleyBlock era)) + +deriving instance ShelleyBasedEra era => Eq (GenTx (ShelleyBlock era)) instance Typeable era => ShowProxy (GenTx (ShelleyBlock era)) where @@ -87,7 +89,8 @@ fixedBlockBodyOverhead = 1024 perTxOverhead :: Num a => a perTxOverhead = 4 -instance TPraosCrypto era => LedgerSupportsMempool (ShelleyBlock era) where +instance ShelleyBasedEra era + => LedgerSupportsMempool (ShelleyBlock era) where txInvariant = const True applyTx = applyShelleyTx @@ -105,7 +108,7 @@ instance TPraosCrypto era => LedgerSupportsMempool (ShelleyBlock era) where where txSize = fromIntegral . Lazy.length . SL.txFullBytes $ tx -mkShelleyTx :: Era era => SL.Tx era -> GenTx (ShelleyBlock era) +mkShelleyTx :: ShelleyBasedEra era => SL.Tx era -> GenTx (ShelleyBlock era) mkShelleyTx tx = ShelleyTx (SL.txid (SL._body tx)) tx newtype instance TxId (GenTx (ShelleyBlock era)) = ShelleyTxId (ShelleyTxId era) @@ -113,10 +116,10 @@ newtype instance TxId (GenTx (ShelleyBlock era)) = ShelleyTxId (ShelleyTxId era) instance Typeable era => ShowProxy (TxId (GenTx (ShelleyBlock era))) where -instance Era era => HasTxId (GenTx (ShelleyBlock era)) where +instance ShelleyBasedEra era => HasTxId (GenTx (ShelleyBlock era)) where txId (ShelleyTx i _) = ShelleyTxId i -instance Era era => HasTxs (ShelleyBlock era) where +instance ShelleyBasedEra era => HasTxs (ShelleyBlock era) where extractTxs = map mkShelleyTx . txSeqToList @@ -130,12 +133,12 @@ instance Era era => HasTxs (ShelleyBlock era) where Serialisation -------------------------------------------------------------------------------} -instance Era era => ToCBOR (GenTx (ShelleyBlock era)) where +instance ShelleyBasedEra era => ToCBOR (GenTx (ShelleyBlock era)) where -- No need to encode the 'TxId', it's just a hash of the 'SL.TxBody' inside -- 'SL.Tx', so it can be recomputed. toCBOR (ShelleyTx _txid tx) = wrapCBORinCBOR toCBOR tx -instance Era era => FromCBOR (GenTx (ShelleyBlock era)) where +instance ShelleyBasedEra era => FromCBOR (GenTx (ShelleyBlock era)) where fromCBOR = fmap mkShelleyTx $ unwrapCBORinCBOR $ (. Full) . runAnnotator <$> fromCBOR @@ -143,13 +146,13 @@ instance Era era => FromCBOR (GenTx (ShelleyBlock era)) where Pretty-printing -------------------------------------------------------------------------------} -instance Era era => Condense (GenTx (ShelleyBlock era)) where +instance ShelleyBasedEra era => Condense (GenTx (ShelleyBlock era)) where condense (ShelleyTx _ tx ) = show tx instance Condense (GenTxId (ShelleyBlock era)) where condense (ShelleyTxId i) = "txid: " <> show i -instance Era era => Show (GenTx (ShelleyBlock era)) where +instance ShelleyBasedEra era => Show (GenTx (ShelleyBlock era)) where show = condense instance Show (GenTxId (ShelleyBlock era)) where @@ -159,8 +162,8 @@ instance Show (GenTxId (ShelleyBlock era)) where Applying transactions -------------------------------------------------------------------------------} -applyShelleyTx - :: TPraosCrypto era +applyShelleyTx :: + ShelleyBasedEra era => LedgerConfig (ShelleyBlock era) -> SlotNo -> GenTx (ShelleyBlock era) @@ -168,9 +171,8 @@ applyShelleyTx -> Except (ApplyTxErr (ShelleyBlock era)) (TickedLedgerState (ShelleyBlock era)) applyShelleyTx cfg slot (ShelleyTx _ tx) st = (\state -> st { tickedShelleyLedgerState = state }) <$> - SL.overShelleyState - (SL.applyTxs globals mempoolEnv (Seq.singleton tx)) - (tickedShelleyLedgerState st) - where - globals = shelleyLedgerGlobals cfg - mempoolEnv = SL.mkMempoolEnv (tickedShelleyLedgerState st) slot + SL.applyTxs + (shelleyLedgerGlobals cfg) + slot + (Seq.singleton tx) + (tickedShelleyLedgerState st) diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/TPraos.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/TPraos.hs index 93437e7ad2f..2793d370469 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/TPraos.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/TPraos.hs @@ -17,6 +17,7 @@ import Ouroboros.Consensus.Protocol.Signed import qualified Shelley.Spec.Ledger.API as SL +import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config import Ouroboros.Consensus.Shelley.Protocol @@ -25,9 +26,9 @@ import Ouroboros.Consensus.Shelley.Protocol Support for Transitional Praos consensus algorithm -------------------------------------------------------------------------------} -type instance BlockProtocol (ShelleyBlock era) = TPraos era +type instance BlockProtocol (ShelleyBlock era) = TPraos (EraCrypto era) -instance TPraosCrypto era => BlockSupportsProtocol (ShelleyBlock era) where +instance ShelleyBasedEra era => BlockSupportsProtocol (ShelleyBlock era) where validateView _cfg (ShelleyHeader hdr _) = hdr selectView cfg hdr@(ShelleyHeader shdr _) = TPraosChainSelectView { @@ -39,11 +40,11 @@ instance TPraosCrypto era => BlockSupportsProtocol (ShelleyBlock era) where , csvLeaderVRF = certifiedOutput . SL.bheaderL $ hdrBody } where - hdrBody :: SL.BHBody era + hdrBody :: SL.BHBody (EraCrypto era) hdrBody = SL.bhbody shdr - issuerVKeys :: Map (SL.KeyHash 'SL.BlockIssuer era) - (SL.VKey 'SL.BlockIssuer era) + issuerVKeys :: Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era)) + (SL.VKey 'SL.BlockIssuer (EraCrypto era)) issuerVKeys = shelleyBlockIssuerVKeys cfg -- | Premature optimisation: we assume everywhere that 'selectView' is @@ -85,7 +86,7 @@ instance TPraosCrypto era => BlockSupportsProtocol (ShelleyBlock era) where -> NotSelfIssued -- TODO correct place for these two? -type instance Signed (Header (ShelleyBlock era)) = SL.BHBody era +type instance Signed (Header (ShelleyBlock era)) = SL.BHBody (EraCrypto era) -instance Era era => SignedHeader (Header (ShelleyBlock era)) where +instance ShelleyBasedEra era => SignedHeader (Header (ShelleyBlock era)) where headerSigned = SL.bhbody . shelleyHeaderRaw diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs index bddaeddb547..50ce410b944 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs @@ -71,13 +71,13 @@ import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey Credentials -------------------------------------------------------------------------------} -data TPraosLeaderCredentials era = TPraosLeaderCredentials { +data TPraosLeaderCredentials c = TPraosLeaderCredentials { -- | The unevolved signing KES key (at evolution 0). -- -- Note that this is not inside 'TPraosCanBeLeader' since it gets evolved -- automatically, whereas 'TPraosCanBeLeader' does not change. - tpraosLeaderCredentialsInitSignKey :: SL.SignKeyKES era - , tpraosLeaderCredentialsCanBeLeader :: TPraosCanBeLeader era + tpraosLeaderCredentialsInitSignKey :: SL.SignKeyKES c + , tpraosLeaderCredentialsCanBeLeader :: TPraosCanBeLeader c -- | Identifier for this set of credentials. -- -- Useful when the node is running with multiple sets of credentials. @@ -85,7 +85,7 @@ data TPraosLeaderCredentials era = TPraosLeaderCredentials { } tpraosBlockIssuerVKey :: - TPraosLeaderCredentials era -> SL.VKey 'SL.BlockIssuer era + TPraosLeaderCredentials c -> SL.VKey 'SL.BlockIssuer c tpraosBlockIssuerVKey = tpraosCanBeLeaderColdVerKey . tpraosLeaderCredentialsCanBeLeader @@ -93,16 +93,16 @@ tpraosBlockIssuerVKey = BlockForging -------------------------------------------------------------------------------} -type instance CannotForge (ShelleyBlock era) = TPraosCannotForge era +type instance CannotForge (ShelleyBlock era) = TPraosCannotForge (EraCrypto era) type instance ForgeStateInfo (ShelleyBlock era) = HotKey.KESInfo type instance ForgeStateUpdateError (ShelleyBlock era) = HotKey.KESEvolutionError -shelleyBlockForging - :: forall m era. (TPraosCrypto era, IOLike m) +shelleyBlockForging :: + forall m era. (ShelleyBasedEra era, IOLike m) => TPraosParams - -> TPraosLeaderCredentials era + -> TPraosLeaderCredentials (EraCrypto era) -> m (BlockForging m (ShelleyBlock era)) shelleyBlockForging TPraosParams {..} TPraosLeaderCredentials { @@ -125,7 +125,7 @@ shelleyBlockForging TPraosParams {..} , forgeBlock = forgeShelleyBlock hotKey canBeLeader } where - forgingVRFHash :: SL.Hash era (SL.VerKeyVRF era) + forgingVRFHash :: SL.Hash (EraCrypto era) (SL.VerKeyVRF (EraCrypto era)) forgingVRFHash = SL.hashVerKeyVRF . VRF.deriveVerKeyVRF @@ -145,7 +145,9 @@ shelleyBlockForging TPraosParams {..} -- | Check the validity of the genesis config. To be used in conjunction with -- 'assertWithMsg'. -validateGenesis :: TPraosCrypto era => SL.ShelleyGenesis era -> Either String () +validateGenesis :: + ShelleyBasedEra era + => SL.ShelleyGenesis era -> Either String () validateGenesis = first errsToString . SL.validateGenesis where errsToString :: [SL.ValidationErr] -> String @@ -163,23 +165,23 @@ data ProtocolParamsShelley c f = ProtocolParamsShelley { -- mutually incompatible. , shelleyInitialNonce :: SL.Nonce , shelleyProtVer :: SL.ProtVer - , shelleyLeaderCredentials :: f (TPraosLeaderCredentials (ShelleyEra c)) + , shelleyLeaderCredentials :: f (TPraosLeaderCredentials c) } -- | Parameters needed to run Allegra data ProtocolParamsAllegra c f = ProtocolParamsAllegra { allegraProtVer :: SL.ProtVer - , allegraLeaderCredentials :: f (TPraosLeaderCredentials (AllegraEra c)) + , allegraLeaderCredentials :: f (TPraosLeaderCredentials c) } -- | Parameters needed to run Mary data ProtocolParamsMary c f = ProtocolParamsMary { maryProtVer :: SL.ProtVer - , maryLeaderCredentials :: f (TPraosLeaderCredentials (MaryEra c)) + , maryLeaderCredentials :: f (TPraosLeaderCredentials c) } protocolInfoShelley :: - forall m c f. (IOLike m, TPraosCrypto (ShelleyEra c), Foldable f) + forall m c f. (IOLike m, ShelleyBasedEra (ShelleyEra c), Foldable f) => ProtocolParamsShelley c f -> ProtocolInfo m (ShelleyBlock (ShelleyEra c)) protocolInfoShelley ProtocolParamsShelley { @@ -242,7 +244,7 @@ protocolInfoShelley ProtocolParamsShelley { , shelleyLedgerTransition = ShelleyTransitionInfo {shelleyAfterVoting = 0} } - initChainDepState :: TPraosState (ShelleyEra c) + initChainDepState :: TPraosState c initChainDepState = TPraosState Origin $ SL.ChainDepState { SL.csProtocol = SL.PrtclState @@ -373,7 +375,7 @@ instance ConfigSupportsNode (ShelleyBlock era) where NodeInitStorage instance -------------------------------------------------------------------------------} -instance TPraosCrypto era => NodeInitStorage (ShelleyBlock era) where +instance ShelleyBasedEra era => NodeInitStorage (ShelleyBlock era) where -- We fix the chunk size to @10k@ so that we have the same chunk size as -- Byron. Consequently, a Shelley net will have the same chunk size as the -- Byron-to-Shelley net with the same @k@. @@ -391,4 +393,4 @@ instance TPraosCrypto era => NodeInitStorage (ShelleyBlock era) where RunNode instance -------------------------------------------------------------------------------} -instance TPraosCrypto era => RunNode (ShelleyBlock era) +instance ShelleyBasedEra era => RunNode (ShelleyBlock era) 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 e9b4ae0579c..7d64dcfcc3a 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Shelley.Node.Serialisation () where @@ -21,6 +22,7 @@ import Ouroboros.Consensus.Storage.Serialisation import qualified Shelley.Spec.Ledger.API as SL +import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () import Ouroboros.Consensus.Shelley.Protocol @@ -29,43 +31,43 @@ import Ouroboros.Consensus.Shelley.Protocol EncodeDisk & DecodeDisk -------------------------------------------------------------------------------} -instance Era era => HasBinaryBlockInfo (ShelleyBlock era) where +instance ShelleyBasedEra era => HasBinaryBlockInfo (ShelleyBlock era) where getBinaryBlockInfo = shelleyBinaryBlockInfo -instance Era era => SerialiseDiskConstraints (ShelleyBlock era) +instance ShelleyBasedEra era => SerialiseDiskConstraints (ShelleyBlock era) -instance Era era => EncodeDisk (ShelleyBlock era) (ShelleyBlock era) where +instance ShelleyBasedEra era => EncodeDisk (ShelleyBlock era) (ShelleyBlock era) where encodeDisk _ = encodeShelleyBlock -instance Era era => DecodeDisk (ShelleyBlock era) (Lazy.ByteString -> ShelleyBlock era) where +instance ShelleyBasedEra era => DecodeDisk (ShelleyBlock era) (Lazy.ByteString -> ShelleyBlock era) where decodeDisk _ = decodeShelleyBlock -instance Era era => EncodeDisk (ShelleyBlock era) (Header (ShelleyBlock era)) where +instance ShelleyBasedEra era => EncodeDisk (ShelleyBlock era) (Header (ShelleyBlock era)) where encodeDisk _ = encodeShelleyHeader -instance Era era => DecodeDisk (ShelleyBlock era) (Lazy.ByteString -> Header (ShelleyBlock era)) where +instance ShelleyBasedEra era => DecodeDisk (ShelleyBlock era) (Lazy.ByteString -> Header (ShelleyBlock era)) where decodeDisk _ = decodeShelleyHeader -instance Era era => EncodeDisk (ShelleyBlock era) (LedgerState (ShelleyBlock era)) where +instance ShelleyBasedEra era => EncodeDisk (ShelleyBlock era) (LedgerState (ShelleyBlock era)) where encodeDisk _ = encodeShelleyLedgerState -instance Era era => DecodeDisk (ShelleyBlock era) (LedgerState (ShelleyBlock era)) where +instance ShelleyBasedEra era => DecodeDisk (ShelleyBlock era) (LedgerState (ShelleyBlock era)) where decodeDisk _ = decodeShelleyLedgerState -- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' era))@ -instance Era era => EncodeDisk (ShelleyBlock era) (TPraosState era) where +instance (ShelleyBasedEra era, EraCrypto era ~ c) => EncodeDisk (ShelleyBlock era) (TPraosState c) where encodeDisk _ = encode -- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' era))@ -instance Era era => DecodeDisk (ShelleyBlock era) (TPraosState era) where +instance (ShelleyBasedEra era, EraCrypto era ~ c) => DecodeDisk (ShelleyBlock era) (TPraosState c) where decodeDisk _ = decode -instance Era era => EncodeDisk (ShelleyBlock era) (AnnTip (ShelleyBlock era)) where +instance ShelleyBasedEra era => EncodeDisk (ShelleyBlock era) (AnnTip (ShelleyBlock era)) where encodeDisk _ = encodeShelleyAnnTip -instance Era era => DecodeDisk (ShelleyBlock era) (AnnTip (ShelleyBlock era)) where +instance ShelleyBasedEra era => DecodeDisk (ShelleyBlock era) (AnnTip (ShelleyBlock era)) where decodeDisk _ = decodeShelleyAnnTip {------------------------------------------------------------------------------- SerialiseNodeToNode -------------------------------------------------------------------------------} -instance Era era => SerialiseNodeToNodeConstraints (ShelleyBlock era) where +instance ShelleyBasedEra era => SerialiseNodeToNodeConstraints (ShelleyBlock era) where estimateBlockSize hdr = overhead + hdrSize + bodySize where -- The maximum block size is 65536, the CBOR-in-CBOR tag for this block @@ -81,7 +83,7 @@ instance Era era => SerialiseNodeToNodeConstraints (ShelleyBlock era) where -- | CBOR-in-CBOR for the annotation. This also makes it compatible with the -- wrapped ('Serialised') variant. -instance Era era => SerialiseNodeToNode (ShelleyBlock era) (ShelleyBlock era) where +instance ShelleyBasedEra era => SerialiseNodeToNode (ShelleyBlock era) (ShelleyBlock era) where encodeNodeToNode _ _ = wrapCBORinCBOR encodeShelleyBlock decodeNodeToNode _ _ = unwrapCBORinCBOR decodeShelleyBlock @@ -90,7 +92,7 @@ instance SerialiseNodeToNode (ShelleyBlock era) (Serialised (ShelleyBlock era)) -- Default instance -- | CBOR-in-CBOR to be compatible with the wrapped ('Serialised') variant. -instance Era era => SerialiseNodeToNode (ShelleyBlock era) (Header (ShelleyBlock era)) where +instance ShelleyBasedEra era => SerialiseNodeToNode (ShelleyBlock era) (Header (ShelleyBlock era)) where encodeNodeToNode _ _ = wrapCBORinCBOR encodeShelleyHeader decodeNodeToNode _ _ = unwrapCBORinCBOR decodeShelleyHeader @@ -101,11 +103,11 @@ instance SerialiseNodeToNode (ShelleyBlock era) (SerialisedHeader (ShelleyBlock -- | The @To/FromCBOR@ instances defined in @cardano-ledger-specs@ use -- CBOR-in-CBOR to get the annotation. -instance Era era => SerialiseNodeToNode (ShelleyBlock era) (GenTx (ShelleyBlock era)) where +instance ShelleyBasedEra era => SerialiseNodeToNode (ShelleyBlock era) (GenTx (ShelleyBlock era)) where encodeNodeToNode _ _ = toCBOR decodeNodeToNode _ _ = fromCBOR -instance Era era => SerialiseNodeToNode (ShelleyBlock era) (GenTxId (ShelleyBlock era)) where +instance ShelleyBasedEra era => SerialiseNodeToNode (ShelleyBlock era) (GenTxId (ShelleyBlock era)) where encodeNodeToNode _ _ = toCBOR decodeNodeToNode _ _ = fromCBOR @@ -113,11 +115,11 @@ instance Era era => SerialiseNodeToNode (ShelleyBlock era) (GenTxId (ShelleyBloc SerialiseNodeToClient -------------------------------------------------------------------------------} -instance Era era => SerialiseNodeToClientConstraints (ShelleyBlock era) +instance ShelleyBasedEra era => SerialiseNodeToClientConstraints (ShelleyBlock era) -- | CBOR-in-CBOR for the annotation. This also makes it compatible with the -- wrapped ('Serialised') variant. -instance Era era => SerialiseNodeToClient (ShelleyBlock era) (ShelleyBlock era) where +instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) (ShelleyBlock era) where encodeNodeToClient _ _ = wrapCBORinCBOR encodeShelleyBlock decodeNodeToClient _ _ = unwrapCBORinCBOR decodeShelleyBlock @@ -126,20 +128,20 @@ instance SerialiseNodeToClient (ShelleyBlock era) (Serialised (ShelleyBlock era) -- Default instance -- | Uses CBOR-in-CBOR in the @To/FromCBOR@ instances to get the annotation. -instance Era era => SerialiseNodeToClient (ShelleyBlock era) (GenTx (ShelleyBlock era)) where +instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) (GenTx (ShelleyBlock era)) where encodeNodeToClient _ _ = toCBOR decodeNodeToClient _ _ = fromCBOR -- | @'ApplyTxErr' '(ShelleyBlock era)'@ -instance Era era => SerialiseNodeToClient (ShelleyBlock era) (SL.ApplyTxError era) where +instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) (SL.ApplyTxError era) where encodeNodeToClient _ _ = toCBOR decodeNodeToClient _ _ = fromCBOR -instance Era era => SerialiseNodeToClient (ShelleyBlock era) (SomeBlock Query (ShelleyBlock era)) where +instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) (SomeBlock Query (ShelleyBlock era)) where encodeNodeToClient _ _ (SomeBlock q) = encodeShelleyQuery q decodeNodeToClient _ _ = decodeShelleyQuery -instance Era era => SerialiseResult (ShelleyBlock era) (Query (ShelleyBlock era)) where +instance ShelleyBasedEra era => SerialiseResult (ShelleyBlock era) (Query (ShelleyBlock era)) where encodeResult _ _ = encodeShelleyResult decodeResult _ _ = decodeShelleyResult @@ -149,8 +151,8 @@ instance Era era => SerialiseResult (ShelleyBlock era) (Query (ShelleyBlock era) Since 'NestedCtxt' for Shelley is trivial, these instances can use defaults. -------------------------------------------------------------------------------} -instance Era era => ReconstructNestedCtxt Header (ShelleyBlock era) -instance Era era => EncodeDiskDepIx (NestedCtxt Header) (ShelleyBlock era) -instance Era era => EncodeDiskDep (NestedCtxt Header) (ShelleyBlock era) -instance Era era => DecodeDiskDepIx (NestedCtxt Header) (ShelleyBlock era) -instance Era era => DecodeDiskDep (NestedCtxt Header) (ShelleyBlock era) +instance ShelleyBasedEra era => ReconstructNestedCtxt Header (ShelleyBlock era) +instance ShelleyBasedEra era => EncodeDiskDepIx (NestedCtxt Header) (ShelleyBlock era) +instance ShelleyBasedEra era => EncodeDiskDep (NestedCtxt Header) (ShelleyBlock era) +instance ShelleyBasedEra era => DecodeDiskDepIx (NestedCtxt Header) (ShelleyBlock era) +instance ShelleyBasedEra era => DecodeDiskDep (NestedCtxt Header) (ShelleyBlock era) diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs index 2fcc27acda8..2e0f4ced219 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs @@ -30,7 +30,6 @@ module Ouroboros.Consensus.Shelley.Protocol ( , mkShelleyGlobals , MaxMajorProtVer (..) -- * Crypto - , Era , TPraosCrypto , StandardCrypto -- * CannotForge @@ -65,7 +64,6 @@ import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Versioned import Cardano.Ledger.Crypto (VRF) -import Cardano.Ledger.Era (Era (Crypto)) import qualified Shelley.Spec.Ledger.API as SL import qualified Shelley.Spec.Ledger.BaseTypes as SL (ActiveSlotCoeff, Seed) import qualified Shelley.Spec.Ledger.BlockChain as SL (checkLeaderValue, mkSeed, @@ -81,54 +79,55 @@ import Ouroboros.Consensus.Shelley.Protocol.Util Fields required by TPraos in the header -------------------------------------------------------------------------------} -data TPraosFields era toSign = TPraosFields { - tpraosSignature :: SL.SignedKES era toSign +data TPraosFields c toSign = TPraosFields { + tpraosSignature :: SL.SignedKES c toSign , tpraosToSign :: toSign } deriving (Generic) -instance (NoThunks toSign, Era era) - => NoThunks (TPraosFields era toSign) -deriving instance (Show toSign, Era era) - => Show (TPraosFields era toSign) +deriving instance (NoThunks toSign, TPraosCrypto c) + => NoThunks (TPraosFields c toSign) +deriving instance (Show toSign, TPraosCrypto c) + => Show (TPraosFields c toSign) -- | Fields arising from transitional praos execution which must be included in -- the block signature. -data TPraosToSign era = TPraosToSign { +data TPraosToSign c = TPraosToSign { -- | Verification key for the issuer of this block. -- -- Note that unlike in Classic/BFT where we have a key for the genesis -- delegate on whose behalf we are issuing this block, this key -- corresponds to the stake pool/core node actually forging the block. - tpraosToSignIssuerVK :: SL.VKey 'SL.BlockIssuer era - , tpraosToSignVrfVK :: SL.VerKeyVRF era + tpraosToSignIssuerVK :: SL.VKey 'SL.BlockIssuer c + , tpraosToSignVrfVK :: SL.VerKeyVRF c -- | Verifiable result containing the updated nonce value. - , tpraosToSignEta :: SL.CertifiedVRF era SL.Nonce + , tpraosToSignEta :: SL.CertifiedVRF c SL.Nonce -- | Verifiable proof of the leader value, used to determine whether the -- node has the right to issue a block in this slot. -- -- We include a value here even for blocks forged under the BFT -- schedule. It is not required that such a value be verifiable (though -- by default it will be verifiably correct, but unused.) - , tpraosToSignLeader :: SL.CertifiedVRF era Natural + , tpraosToSignLeader :: SL.CertifiedVRF c Natural -- | Lightweight delegation certificate mapping the cold (DSIGN) key to -- the online KES key. - , tpraosToSignOCert :: SL.OCert era + , tpraosToSignOCert :: SL.OCert c } deriving (Generic) -instance Era era => NoThunks (TPraosToSign era) -deriving instance Era era => Show (TPraosToSign era) - -forgeTPraosFields :: ( Era era - , SL.KESignable era toSign - , Monad m - ) - => HotKey era m - -> CanBeLeader (TPraos era) - -> IsLeader (TPraos era) - -> (TPraosToSign era -> toSign) - -> m (TPraosFields era toSign) +instance TPraosCrypto c => NoThunks (TPraosToSign c) +deriving instance TPraosCrypto c => Show (TPraosToSign c) + +forgeTPraosFields :: + ( TPraosCrypto c + , SL.KESignable c toSign + , Monad m + ) + => HotKey c m + -> CanBeLeader (TPraos c) + -> IsLeader (TPraos c) + -> (TPraosToSign c -> toSign) + -> m (TPraosFields c toSign) forgeTPraosFields hotKey TPraosCanBeLeader{..} TPraosIsLeader{..} mkToSign = do signature <- HotKey.sign hotKey toSign return TPraosFields { @@ -149,7 +148,7 @@ forgeTPraosFields hotKey TPraosCanBeLeader{..} TPraosIsLeader{..} mkToSign = do -- | Because we are using the executable spec, rather than implementing the -- protocol directly here, we have a fixed header type rather than an -- abstraction. So our validate view is fixed to this. -type TPraosValidateView era = SL.BHeader era +type TPraosValidateView c = SL.BHeader c {------------------------------------------------------------------------------- Protocol proper @@ -164,7 +163,7 @@ newtype MaxMajorProtVer = MaxMajorProtVer { } deriving (Eq, Show, Generic, NoThunks) -data TPraos era +data TPraos c -- | TPraos parameters that are node independent data TPraosParams = TPraosParams { @@ -220,40 +219,39 @@ mkTPraosParams maxMajorPV initialNonce genesis = TPraosParams { where securityParam = SecurityParam $ SL.sgSecurityParam genesis -data TPraosCanBeLeader era = TPraosCanBeLeader { +data TPraosCanBeLeader c = TPraosCanBeLeader { -- | Certificate delegating rights from the stake pool cold key (or -- genesis stakeholder delegate cold key) to the online KES key. - tpraosCanBeLeaderOpCert :: !(SL.OCert era) + tpraosCanBeLeaderOpCert :: !(SL.OCert c) -- | Stake pool cold key or genesis stakeholder delegate cold key. - , tpraosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer era) - , tpraosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF era) + , tpraosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer c) + , tpraosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c) } deriving (Generic) -instance Era era => NoThunks (TPraosCanBeLeader era) +instance TPraosCrypto c => NoThunks (TPraosCanBeLeader c) -- | Assembled proof that the issuer has the right to issue a block in the -- selected slot. -data TPraosIsLeader era = TPraosIsLeader { - tpraosIsLeaderEta :: SL.CertifiedVRF era SL.Nonce - , tpraosIsLeaderProof :: SL.CertifiedVRF era Natural +data TPraosIsLeader c = TPraosIsLeader { + tpraosIsLeaderEta :: SL.CertifiedVRF c SL.Nonce + , tpraosIsLeaderProof :: SL.CertifiedVRF c Natural -- | When in the overlay schedule (otherwise 'Nothing'), return the hash -- of the VRF verification key in the overlay schedule - , tpraosIsLeaderGenVRFHash :: Maybe (SL.Hash era (SL.VerKeyVRF era)) + , tpraosIsLeaderGenVRFHash :: Maybe (SL.Hash c (SL.VerKeyVRF c)) } deriving (Generic) -instance Era era => NoThunks (TPraosIsLeader era) +instance TPraosCrypto c => NoThunks (TPraosIsLeader c) -- | Static configuration -data instance ConsensusConfig (TPraos era) = TPraosConfig { +data instance ConsensusConfig (TPraos c) = TPraosConfig { tpraosParams :: !TPraosParams , tpraosEpochInfo :: !(EpochInfo Identity) } deriving (Generic) --- Use generic instance -instance Era era => NoThunks (ConsensusConfig (TPraos era)) +instance TPraosCrypto c => NoThunks (ConsensusConfig (TPraos c)) -- | Separate type instead of 'Bool' for the custom 'Ord' instance + -- documentation. @@ -280,16 +278,16 @@ instance Ord SelfIssued where -- 3. If the tip of each chain was issued by the same agent, then we prefer -- the chain whose tip has the highest ocert issue number. -- 4. By the leader value of the chain tip, with lower values preferred. -data TPraosChainSelectView era = TPraosChainSelectView { +data TPraosChainSelectView c = TPraosChainSelectView { csvChainLength :: BlockNo , csvSlotNo :: SlotNo , csvSelfIssued :: SelfIssued - , csvIssuer :: SL.VKey 'SL.BlockIssuer era + , csvIssuer :: SL.VKey 'SL.BlockIssuer c , csvIssueNo :: Word64 - , csvLeaderVRF :: VRF.OutputVRF (VRF (Crypto era)) + , csvLeaderVRF :: VRF.OutputVRF (VRF c) } deriving (Show, Eq) -instance Era era => Ord (TPraosChainSelectView era) where +instance TPraosCrypto c => Ord (TPraosChainSelectView c) where compare = mconcat [ compare `on` csvChainLength @@ -311,35 +309,35 @@ instance Era era => Ord (TPraosChainSelectView era) where | otherwise = EQ -instance Era era => ChainSelection (TPraos era) where +instance TPraosCrypto c => ChainSelection (TPraos c) where -- | Chain selection is done on the basis of the chain length first, and then -- operational certificate issue number. - type SelectView (TPraos era) = TPraosChainSelectView era + type SelectView (TPraos c) = TPraosChainSelectView c -- | Ledger view at a particular slot -newtype instance Ticked (SL.LedgerView era) = TickedPraosLedgerView { +newtype instance Ticked (SL.LedgerView c) = TickedPraosLedgerView { -- TODO: Perhaps it would be cleaner to define this as a separate type - getTickedPraosLedgerView :: SL.LedgerView era + getTickedPraosLedgerView :: SL.LedgerView c } -- | Transitional Praos consensus state. -- -- In addition to the 'ChainDepState' provided by the ledger, we track the slot -- number of the last applied header. -data TPraosState era = TPraosState { +data TPraosState c = TPraosState { tpraosStateLastSlot :: !(WithOrigin SlotNo) - , tpraosStateChainDepState :: !(SL.ChainDepState era) + , tpraosStateChainDepState :: !(SL.ChainDepState c) } deriving (Generic, Show, Eq) -instance Era era => NoThunks (TPraosState era) +instance TPraosCrypto c => NoThunks (TPraosState c) -- | Version 0 supported rollback, removed in #2575. serialisationFormatVersion1 :: VersionNumber serialisationFormatVersion1 = 1 -instance Era era => Serialise (TPraosState era) where +instance TPraosCrypto c => Serialise (TPraosState c) where encode (TPraosState slot chainDepState) = encodeVersion serialisationFormatVersion1 $ mconcat [ CBOR.encodeListLen 2 @@ -355,19 +353,18 @@ instance Era era => Serialise (TPraosState era) where TPraosState <$> fromCBOR <*> fromCBOR -- | Ticked 'TPraosState' --- -data instance Ticked (TPraosState era) = TickedChainDepState { - tickedTPraosStateChainDepState :: SL.ChainDepState era - , tickedTPraosStateLedgerView :: Ticked (LedgerView (TPraos era)) +data instance Ticked (TPraosState c) = TickedChainDepState { + tickedTPraosStateChainDepState :: SL.ChainDepState c + , tickedTPraosStateLedgerView :: Ticked (LedgerView (TPraos c)) } -instance TPraosCrypto era => ConsensusProtocol (TPraos era) where - type ChainDepState (TPraos era) = TPraosState era - type IsLeader (TPraos era) = TPraosIsLeader era - type CanBeLeader (TPraos era) = TPraosCanBeLeader era - type LedgerView (TPraos era) = SL.LedgerView era - type ValidationErr (TPraos era) = SL.ChainTransitionError era - type ValidateView (TPraos era) = TPraosValidateView era +instance TPraosCrypto c => ConsensusProtocol (TPraos c) where + type ChainDepState (TPraos c) = TPraosState c + type IsLeader (TPraos c) = TPraosIsLeader c + type CanBeLeader (TPraos c) = TPraosCanBeLeader c + type LedgerView (TPraos c) = SL.LedgerView c + type ValidationErr (TPraos c) = SL.ChainTransitionError c + type ValidateView (TPraos c) = TPraosValidateView c protocolSecurityParam = tpraosSecurityParam . tpraosParams @@ -408,7 +405,7 @@ instance TPraosCrypto era => ConsensusProtocol (TPraos era) where where chainState = tickedTPraosStateChainDepState cs lv = getTickedPraosLedgerView $ tickedTPraosStateLedgerView cs - d = SL._d $ SL.lvProtParams lv + d = SL.lvD lv asc = tpraosLeaderF $ tpraosParams cfg firstSlot = firstSlotOfEpochOfSlot (tpraosEpochInfo cfg) slot gkeys = Map.keysSet dlgMap @@ -479,21 +476,20 @@ mkShelleyGlobals epochInfo TPraosParams {..} = SL.Globals { -- | Check whether this node meets the leader threshold to issue a block. meetsLeaderThreshold :: - forall era. Era era - => ConsensusConfig (TPraos era) - -> LedgerView (TPraos era) - -> SL.KeyHash 'SL.StakePool era - -> SL.CertifiedVRF era SL.Seed + forall c. TPraosCrypto c + => ConsensusConfig (TPraos c) + -> LedgerView (TPraos c) + -> SL.KeyHash 'SL.StakePool c + -> SL.CertifiedVRF c SL.Seed -> Bool -meetsLeaderThreshold - TPraosConfig { tpraosParams } - SL.LedgerView { lvPoolDistr } - keyHash - certNat - = SL.checkLeaderValue - (VRF.certifiedOutput certNat) - r - (tpraosLeaderF tpraosParams) +meetsLeaderThreshold TPraosConfig { tpraosParams } + SL.LedgerView { lvPoolDistr } + keyHash + certNat = + SL.checkLeaderValue + (VRF.certifiedOutput certNat) + r + (tpraosLeaderF tpraosParams) where SL.PoolDistr poolDistr = lvPoolDistr r = maybe 0 SL.individualPoolStake @@ -505,7 +501,7 @@ meetsLeaderThreshold -- | Expresses that, whilst we believe ourselves to be a leader for this slot, -- we are nonetheless unable to forge a block. -data TPraosCannotForge era = +data TPraosCannotForge c = -- | The KES key in our operational certificate can't be used because the -- current (wall clock) period is before the start period of the key. -- current KES period. @@ -523,24 +519,24 @@ data TPraosCannotForge era = -- | We are a genesis delegate, but our VRF key (second argument) does not -- match the registered key for that delegate (first argument). | TPraosCannotForgeWrongVRF - !(SL.Hash era (SL.VerKeyVRF era)) - !(SL.Hash era (SL.VerKeyVRF era)) + !(SL.Hash c (SL.VerKeyVRF c)) + !(SL.Hash c (SL.VerKeyVRF c)) deriving (Generic) -deriving instance Era era => Show (TPraosCannotForge era) +deriving instance TPraosCrypto c => Show (TPraosCannotForge c) tpraosCheckCanForge :: - ConsensusConfig (TPraos era) - -> SL.Hash era (SL.VerKeyVRF era) + ConsensusConfig (TPraos c) + -> SL.Hash c (SL.VerKeyVRF c) -- ^ Precomputed hash of the VRF verification key -> SlotNo - -> IsLeader (TPraos era) + -> IsLeader (TPraos c) -> HotKey.KESInfo - -> Either (TPraosCannotForge era) () -tpraosCheckCanForge TPraosConfig{tpraosParams} + -> Either (TPraosCannotForge c) () +tpraosCheckCanForge TPraosConfig { tpraosParams } forgingVRFHash curSlot - TPraosIsLeader{tpraosIsLeaderGenVRFHash} + TPraosIsLeader { tpraosIsLeaderGenVRFHash } kesInfo | let startPeriod = HotKey.kesStartPeriod kesInfo , startPeriod > wallclockPeriod @@ -560,5 +556,5 @@ tpraosCheckCanForge TPraosConfig{tpraosParams} Condense -------------------------------------------------------------------------------} -instance (Condense toSign, Era era) => Condense (TPraosFields era toSign) where +instance (Condense toSign, TPraosCrypto c) => Condense (TPraosFields c toSign) where condense = condense . tpraosToSign 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 a577f6953b6..9c27358711a 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto.hs @@ -13,23 +13,19 @@ import Cardano.Crypto.KES.Sum import Cardano.Crypto.VRF.Praos (PraosVRF) import Cardano.Ledger.Crypto (Crypto (..)) -import Cardano.Ledger.Era (Era) -import Cardano.Ledger.Shelley (Shelley) - -import Shelley.Spec.Ledger.API (BHBody, Hash, TxBody) +import Shelley.Spec.Ledger.API (BHBody, Hash) import Shelley.Spec.Ledger.BaseTypes (Seed) import qualified Shelley.Spec.Ledger.Keys as SL (DSignable, KESignable, VRFSignable) import Shelley.Spec.Ledger.OCert (OCertSignable) +import Shelley.Spec.Ledger.TxBody (EraIndependentTxBody) --- TODO #2668 these constraints and types should be parameterised by @crypto@, --- not @era@. -class ( Era era - , SL.DSignable era (OCertSignable era) - , SL.DSignable era (Hash era (TxBody era)) - , SL.KESignable era (BHBody era) - , SL.VRFSignable era Seed - ) => TPraosCrypto era +class ( Crypto c + , SL.DSignable c (OCertSignable c) + , SL.DSignable c (Hash c EraIndependentTxBody) + , SL.KESignable c (BHBody c) + , SL.VRFSignable c Seed + ) => TPraosCrypto c data StandardCrypto @@ -40,4 +36,4 @@ instance Crypto StandardCrypto where type HASH StandardCrypto = Blake2b_256 type ADDRHASH StandardCrypto = Blake2b_224 -instance TPraosCrypto (Shelley StandardCrypto) +instance TPraosCrypto StandardCrypto diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/HotKey.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/HotKey.hs index a44ca556b3e..683630e1451 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/HotKey.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/HotKey.hs @@ -33,7 +33,7 @@ import qualified Cardano.Crypto.KES as Relative (Period) import Ouroboros.Consensus.Block (UpdateInfo (..)) import Ouroboros.Consensus.Util.IOLike -import Cardano.Ledger.Era (Era) +import Cardano.Ledger.Crypto (Crypto) import qualified Shelley.Spec.Ledger.Keys as SL import qualified Shelley.Spec.Ledger.OCert as Absolute (KESPeriod (..)) @@ -124,7 +124,7 @@ data KESEvolutionError = type KESEvolutionInfo = UpdateInfo KESInfo KESInfo KESEvolutionError -- | API to interact with the key. -data HotKey era m = HotKey { +data HotKey c m = HotKey { -- | Evolve the KES signing key to the given absolute KES period. -- -- When the key cannot evolve anymore, we poison it. @@ -138,43 +138,43 @@ data HotKey era m = HotKey { -- PRECONDITION: the key is not poisoned. -- -- POSTCONDITION: the signature is in normal form. - , sign_ :: forall toSign. (SL.KESignable era toSign, HasCallStack) - => toSign -> m (SL.SignedKES era toSign) + , sign_ :: forall toSign. (SL.KESignable c toSign, HasCallStack) + => toSign -> m (SL.SignedKES c toSign) } sign :: - (SL.KESignable era toSign, HasCallStack) - => HotKey era m - -> toSign -> m (SL.SignedKES era toSign) + (SL.KESignable c toSign, HasCallStack) + => HotKey c m + -> toSign -> m (SL.SignedKES c toSign) sign = sign_ -- | The actual KES key, unless it expired, in which case it is replaced by -- \"poison\". -data KESKey era = - KESKey !(SL.SignKeyKES era) +data KESKey c = + KESKey !(SL.SignKeyKES c) | KESKeyPoisoned deriving (Generic) -instance Era era => NoThunks (KESKey era) +instance Crypto c => NoThunks (KESKey c) -kesKeyIsPoisoned :: KESKey era -> Bool +kesKeyIsPoisoned :: KESKey c -> Bool kesKeyIsPoisoned KESKeyPoisoned = True kesKeyIsPoisoned (KESKey _) = False -data KESState era = KESState { +data KESState c = KESState { kesStateInfo :: !KESInfo - , kesStateKey :: !(KESKey era) + , kesStateKey :: !(KESKey c) } deriving (Generic) -instance Era era => NoThunks (KESState era) +instance Crypto c => NoThunks (KESState c) mkHotKey :: - forall m era. (Era era, IOLike m) - => SL.SignKeyKES era + forall m c. (Crypto c, IOLike m) + => SL.SignKeyKES c -> Absolute.KESPeriod -- ^ Start period -> Word64 -- ^ Max KES evolutions - -> m (HotKey era m) + -> m (HotKey c m) mkHotKey initKey startPeriod@(Absolute.KESPeriod start) maxKESEvolutions = do varKESState <- newMVar initKESState return HotKey { @@ -194,7 +194,7 @@ mkHotKey initKey startPeriod@(Absolute.KESPeriod start) maxKESEvolutions = do evaluate signed } where - initKESState :: KESState era + initKESState :: KESState c initKESState = KESState { kesStateInfo = KESInfo { kesStartPeriod = startPeriod @@ -219,8 +219,8 @@ mkHotKey initKey startPeriod@(Absolute.KESPeriod start) maxKESEvolutions = do -- -- When the key is poisoned, we always return 'UpdateFailed'. evolveKey :: - forall m era. (Era era, IOLike m) - => StrictMVar m (KESState era) -> Absolute.KESPeriod -> m KESEvolutionInfo + forall m c. (Crypto c, IOLike m) + => StrictMVar m (KESState c) -> Absolute.KESPeriod -> m KESEvolutionInfo evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do let info = kesStateInfo kesState -- We mask the evolution process because if we got interrupted after @@ -257,13 +257,13 @@ evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do go targetEvolution info key where - poisonState :: KESState era -> KESState era + poisonState :: KESState c -> KESState c poisonState kesState = kesState { kesStateKey = KESKeyPoisoned } -- | PRECONDITION: -- -- > targetEvolution >= curEvolution - go :: KESEvolution -> KESInfo -> SL.SignKeyKES era -> m (KESState era) + go :: KESEvolution -> KESInfo -> SL.SignKeyKES c -> m (KESState c) go targetEvolution info key | targetEvolution <= curEvolution = return $ KESState { kesStateInfo = info, kesStateKey = KESKey key }