From ae19f32dde67371bd34a01b13f7a55496f130340 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 29 Oct 2020 09:49:30 +0100 Subject: [PATCH 1/4] Rename rightToMaybe to eitherToMaybe The name was inconsistent: `Right` is a constructor and `Maybe` is a type. `eitherToMaybe` already existed in `Ouroboros.Consensus.Byron.Crypto.DSIGN`. Remove this one and reuse the one from `Ouroboros.Consensus.Util`. --- .../src/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs | 4 +--- .../src/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs | 4 ++-- ouroboros-consensus/src/Ouroboros/Consensus/Util.hs | 8 ++++---- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs index 97b62f15c87..f9f8590e24d 100644 --- a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs +++ b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs @@ -42,6 +42,7 @@ import Cardano.Crypto.Seed (SeedBytesExhausted (..), getBytesFromSeed) import qualified Cardano.Crypto.Signing as Crypto import qualified Cardano.Crypto.Wallet as CC +import Ouroboros.Consensus.Util (eitherToMaybe) import Ouroboros.Consensus.Util.Condense class (HasSignTag a, Decoded a) => ByronSignable a @@ -122,8 +123,5 @@ instance DSIGNAlgorithm ByronDSIGN where rawDeserialiseSigDSIGN bs = SigByronDSIGN . Signature <$> (eitherToMaybe $ CC.xsignature bs) -eitherToMaybe :: Either a b -> Maybe b -eitherToMaybe = either (const Nothing) (Just) - instance Condense (SigDSIGN ByronDSIGN) where condense (SigByronDSIGN s) = show s diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 585ae56c084..403dff098b4 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -40,7 +40,7 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.HeaderStateHistory (HeaderStateHistory) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Util (rightToMaybe) +import Ouroboros.Consensus.Util (eitherToMaybe) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) @@ -279,7 +279,7 @@ getAnyBlockComponent immutableDB volatileDB blockComponent p = do -- didn't contain it, so return 'Nothing'. return Nothing else - rightToMaybe <$> + eitherToMaybe <$> ImmutableDB.getBlockComponent immutableDB blockComponent p where hash = realPointHash p diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs index e367ceb52a1..2ae2793b834 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util.hs @@ -63,7 +63,7 @@ module Ouroboros.Consensus.Util ( , pairSnd -- * Miscellaneous , fib - , rightToMaybe + , eitherToMaybe ) where import Cardano.Crypto.Hash (Hash, HashAlgorithm, hashFromBytes, @@ -383,6 +383,6 @@ fib n = round $ phi ** fromIntegral n / sq5 sq5 = sqrt 5 phi = (1 + sq5) / 2 -rightToMaybe :: Either a b -> Maybe b -rightToMaybe (Left _) = Nothing -rightToMaybe (Right x) = Just x +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Left _) = Nothing +eitherToMaybe (Right x) = Just x From ce32ed79be7c754cc6e7b84c5c5ee549cbe9d4a3 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 29 Oct 2020 10:12:51 +0100 Subject: [PATCH 2/4] Update ledger dependency This pulls in https://github.com/input-output-hk/cardano-ledger-specs/pull/1944 which moves `ShelleyBasedEra` and `TPraosCrypto` (renamed to `PraosCrypto`) to `cardano-ledger-specs`. --- cabal.project | 4 +-- .../src/Test/Consensus/Cardano/MockCrypto.hs | 4 +-- .../Consensus/Cardano/CanHardFork.hs | 4 +-- .../src/Test/Consensus/Shelley/Examples.hs | 4 +-- .../src/Test/Consensus/Shelley/Generators.hs | 6 ++-- .../src/Test/Consensus/Shelley/MockCrypto.hs | 4 +-- .../src/Test/ThreadNet/Infra/Shelley.hs | 16 ++++----- .../src/Ouroboros/Consensus/Shelley/Eras.hs | 25 ++------------ .../Ouroboros/Consensus/Shelley/Protocol.hs | 34 +++++++++---------- .../Consensus/Shelley/Protocol/Crypto.hs | 23 +++---------- 10 files changed, 45 insertions(+), 79 deletions(-) diff --git a/cabal.project b/cabal.project index 9c9aeb95cd3..22680e0de3e 100644 --- a/cabal.project +++ b/cabal.project @@ -152,8 +152,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger-specs - tag: 623bbb8d4b13bcb0157c5c576a69536387f1b5be - --sha256: 0nspz67p6ixw4zr6q4r2gzn37583mlag8f1g5pk0i4f1yisi69d1 + tag: c03dd5592bde3bf4f9726f257ba09235aeb4818d + --sha256: 1rpjrcc45s58f76zp5mnibqwkgap5yipzgsgp2fhydcysm1rwblf subdir: byron/chain/executable-spec byron/crypto 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 bb10736f333..422850203fa 100644 --- a/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/MockCrypto.hs +++ b/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/MockCrypto.hs @@ -13,7 +13,7 @@ import Cardano.Crypto.KES (MockKES) import Cardano.Ledger.Crypto (Crypto (..)) import Test.Cardano.Crypto.VRF.Fake (FakeVRF) -import Ouroboros.Consensus.Shelley.Protocol.Crypto (TPraosCrypto) +import Ouroboros.Consensus.Shelley.Protocol.Crypto (PraosCrypto) -- | A replacement for 'Test.Consensus.Shelley.MockCrypto' that is compatible -- with bootstrapping from Byron. @@ -42,4 +42,4 @@ instance Crypto MockCryptoCompatByron where type KES MockCryptoCompatByron = MockKES 10 type VRF MockCryptoCompatByron = FakeVRF -instance TPraosCrypto MockCryptoCompatByron +instance PraosCrypto MockCryptoCompatByron diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs index b5ffc01044a..a8ea751c064 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -310,7 +310,7 @@ instance ShelleyBasedEra era => SingleEraBlock (ShelleyBlock era) where singleEraName = "Shelley" } -instance TPraosCrypto c => HasPartialConsensusConfig (TPraos c) where +instance PraosCrypto c => HasPartialConsensusConfig (TPraos c) where type PartialConsensusConfig (TPraos c) = TPraosParams completeConsensusConfig _ tpraosEpochInfo tpraosParams = TPraosConfig {..} @@ -347,7 +347,7 @@ instance ShelleyBasedEra era => HasPartialLedgerConfig (ShelleyBlock era) where -------------------------------------------------------------------------------} type CardanoHardForkConstraints c = - ( TPraosCrypto c + ( PraosCrypto c , ShelleyBasedEra (ShelleyEra c) , ShelleyBasedEra (AllegraEra c) , ShelleyBasedEra (MaryEra c) 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 a05d0d5cd43..70318f3fdfc 100644 --- a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs @@ -95,7 +95,7 @@ import qualified Test.Shelley.Spec.Ledger.Utils as SL hiding (mkKeyPair, import Ouroboros.Consensus.Shelley.Eras (EraCrypto, StandardShelley) import Ouroboros.Consensus.Shelley.Ledger -import Ouroboros.Consensus.Shelley.Protocol (TPraosCrypto, +import Ouroboros.Consensus.Shelley.Protocol (PraosCrypto, TPraosState (..)) import Test.Util.Orphans.Arbitrary () @@ -236,7 +236,7 @@ examples = Golden.Examples { (mkKeyHash 0) (SL.emptyPParamsUpdate {SL._keyDeposit = SJust (SL.Coin 100)}) -examplePoolDistr :: forall c. TPraosCrypto c => SL.PoolDistr c +examplePoolDistr :: forall c. PraosCrypto c => SL.PoolDistr c examplePoolDistr = SL.PoolDistr $ Map.fromList [ (mkKeyHash 1, SL.IndividualPoolStake 1 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 64a89ff6fee..b5bd3f05bb7 100644 --- a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs +++ b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs @@ -26,7 +26,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool import qualified Shelley.Spec.Ledger.API as SL import Ouroboros.Consensus.Shelley.Ledger -import Ouroboros.Consensus.Shelley.Protocol (TPraosCrypto, +import Ouroboros.Consensus.Shelley.Protocol (PraosCrypto, TPraosState (..)) import Generic.Random (genericArbitraryU) @@ -104,7 +104,7 @@ instance CanMock era => Arbitrary (NonMyopicMemberRewards era) where instance CanMock era => Arbitrary (Point (ShelleyBlock era)) where arbitrary = BlockPoint <$> arbitrary <*> arbitrary -instance TPraosCrypto c => Arbitrary (TPraosState c) where +instance PraosCrypto c => Arbitrary (TPraosState c) where arbitrary = do lastSlot <- frequency [ (1, return Origin) @@ -151,7 +151,7 @@ instance Arbitrary (SL.PParams' SL.StrictMaybe era) where arbitrary = genericArbitraryU shrink = genericShrink -instance TPraosCrypto c => Arbitrary (SL.ChainDepState c) where +instance PraosCrypto 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 d1a6729ad41..ac7b94aff20 100644 --- a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/MockCrypto.hs +++ b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/MockCrypto.hs @@ -29,7 +29,7 @@ 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) +import Ouroboros.Consensus.Shelley.Protocol.Crypto (PraosCrypto) -- | A mock replacement for 'StandardCrypto' -- @@ -48,7 +48,7 @@ instance HashAlgorithm h => Crypto (MockCrypto h) where type MockShelley h = ShelleyEra (MockCrypto h) -instance HashAlgorithm h => TPraosCrypto (MockCrypto h) +instance HashAlgorithm h => PraosCrypto (MockCrypto h) type Block h = ShelleyBlock (MockShelley h) 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 4a09d85f9c4..2ca44f2ec0d 100644 --- a/ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs @@ -143,7 +143,7 @@ data CoreNodeKeyInfo c = CoreNodeKeyInfo ) } -coreNodeKeys :: forall c. TPraosCrypto c => CoreNode c -> CoreNodeKeyInfo c +coreNodeKeys :: forall c. PraosCrypto c => CoreNode c -> CoreNodeKeyInfo c coreNodeKeys CoreNode{cnGenesisKey, cnDelegateKey, cnStakingKey} = CoreNodeKeyInfo { cnkiCoreNode = @@ -162,7 +162,7 @@ coreNodeKeys CoreNode{cnGenesisKey, cnDelegateKey, cnStakingKey} = } genCoreNode :: - forall c. TPraosCrypto c + forall c. PraosCrypto c => SL.KESPeriod -> Gen (CoreNode c) genCoreNode startKESPeriod = do @@ -200,7 +200,7 @@ genCoreNode startKESPeriod = do genSeed :: Integral a => a -> Gen Cardano.Crypto.Seed genSeed = fmap mkSeedFromBytes . genBytes -mkLeaderCredentials :: TPraosCrypto c => CoreNode c -> TPraosLeaderCredentials c +mkLeaderCredentials :: PraosCrypto c => CoreNode c -> TPraosLeaderCredentials c mkLeaderCredentials CoreNode { cnDelegateKey, cnVRF, cnKES, cnOCert } = TPraosLeaderCredentials { tpraosLeaderCredentialsInitSignKey = cnKES @@ -265,7 +265,7 @@ 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 (EraCrypto era) + :: forall era. PraosCrypto (EraCrypto era) => ProtVer -- ^ Initial protocol version -> SecurityParam -> Rational -- ^ Initial active slot coefficient @@ -510,17 +510,17 @@ initialLovelacePerCoreNode :: Word64 initialLovelacePerCoreNode = 1000 mkCredential :: - TPraosCrypto (EraCrypto era) + PraosCrypto (EraCrypto era) => SL.SignKeyDSIGN (EraCrypto era) -> SL.Credential r era mkCredential = SL.KeyHashObj . mkKeyHash -mkKeyHash :: TPraosCrypto c => SL.SignKeyDSIGN c -> SL.KeyHash r c +mkKeyHash :: PraosCrypto c => SL.SignKeyDSIGN c -> SL.KeyHash r c mkKeyHash = SL.hashKey . mkVerKey -mkVerKey :: TPraosCrypto c => SL.SignKeyDSIGN c -> SL.VKey r c +mkVerKey :: PraosCrypto c => SL.SignKeyDSIGN c -> SL.VKey r c mkVerKey = SL.VKey . deriveVerKeyDSIGN -mkKeyPair :: TPraosCrypto c => SL.SignKeyDSIGN c -> SL.KeyPair r c +mkKeyPair :: PraosCrypto c => SL.SignKeyDSIGN c -> SL.KeyPair r c mkKeyPair sk = SL.KeyPair { vKey = mkVerKey sk, sKey = sk } mkKeyHashVrf :: (HashAlgorithm h, VRFAlgorithm vrf) diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs index e4d99056d18..43c28323b8a 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.Shelley.Eras ( -- * Eras based on the Shelley ledger ShelleyEra @@ -19,12 +16,10 @@ module Ouroboros.Consensus.Shelley.Eras ( ) where import Cardano.Ledger.Era (Crypto) -import Cardano.Ledger.Shelley (ShelleyBased, ShelleyEra) +import Cardano.Ledger.Shelley (ShelleyEra) -import qualified Shelley.Spec.Ledger.API as SL - -import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto, - TPraosCrypto) +import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) +import Shelley.Spec.Ledger.API (ShelleyBasedEra) {------------------------------------------------------------------------------- Eras based on the Shelley ledger @@ -58,20 +53,6 @@ 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 -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs index 2e0f4ced219..db303b6d3d9 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs @@ -30,7 +30,7 @@ module Ouroboros.Consensus.Shelley.Protocol ( , mkShelleyGlobals , MaxMajorProtVer (..) -- * Crypto - , TPraosCrypto + , PraosCrypto , StandardCrypto -- * CannotForge , TPraosCannotForge (..) @@ -85,9 +85,9 @@ data TPraosFields c toSign = TPraosFields { } deriving (Generic) -deriving instance (NoThunks toSign, TPraosCrypto c) +deriving instance (NoThunks toSign, PraosCrypto c) => NoThunks (TPraosFields c toSign) -deriving instance (Show toSign, TPraosCrypto c) +deriving instance (Show toSign, PraosCrypto c) => Show (TPraosFields c toSign) -- | Fields arising from transitional praos execution which must be included in @@ -115,11 +115,11 @@ data TPraosToSign c = TPraosToSign { } deriving (Generic) -instance TPraosCrypto c => NoThunks (TPraosToSign c) -deriving instance TPraosCrypto c => Show (TPraosToSign c) +instance PraosCrypto c => NoThunks (TPraosToSign c) +deriving instance PraosCrypto c => Show (TPraosToSign c) forgeTPraosFields :: - ( TPraosCrypto c + ( PraosCrypto c , SL.KESignable c toSign , Monad m ) @@ -229,7 +229,7 @@ data TPraosCanBeLeader c = TPraosCanBeLeader { } deriving (Generic) -instance TPraosCrypto c => NoThunks (TPraosCanBeLeader c) +instance PraosCrypto c => NoThunks (TPraosCanBeLeader c) -- | Assembled proof that the issuer has the right to issue a block in the -- selected slot. @@ -242,7 +242,7 @@ data TPraosIsLeader c = TPraosIsLeader { } deriving (Generic) -instance TPraosCrypto c => NoThunks (TPraosIsLeader c) +instance PraosCrypto c => NoThunks (TPraosIsLeader c) -- | Static configuration data instance ConsensusConfig (TPraos c) = TPraosConfig { @@ -251,7 +251,7 @@ data instance ConsensusConfig (TPraos c) = TPraosConfig { } deriving (Generic) -instance TPraosCrypto c => NoThunks (ConsensusConfig (TPraos c)) +instance PraosCrypto c => NoThunks (ConsensusConfig (TPraos c)) -- | Separate type instead of 'Bool' for the custom 'Ord' instance + -- documentation. @@ -287,7 +287,7 @@ data TPraosChainSelectView c = TPraosChainSelectView { , csvLeaderVRF :: VRF.OutputVRF (VRF c) } deriving (Show, Eq) -instance TPraosCrypto c => Ord (TPraosChainSelectView c) where +instance PraosCrypto c => Ord (TPraosChainSelectView c) where compare = mconcat [ compare `on` csvChainLength @@ -309,7 +309,7 @@ instance TPraosCrypto c => Ord (TPraosChainSelectView c) where | otherwise = EQ -instance TPraosCrypto c => ChainSelection (TPraos c) where +instance PraosCrypto c => ChainSelection (TPraos c) where -- | Chain selection is done on the basis of the chain length first, and then -- operational certificate issue number. @@ -331,13 +331,13 @@ data TPraosState c = TPraosState { } deriving (Generic, Show, Eq) -instance TPraosCrypto c => NoThunks (TPraosState c) +instance PraosCrypto c => NoThunks (TPraosState c) -- | Version 0 supported rollback, removed in #2575. serialisationFormatVersion1 :: VersionNumber serialisationFormatVersion1 = 1 -instance TPraosCrypto c => Serialise (TPraosState c) where +instance PraosCrypto c => Serialise (TPraosState c) where encode (TPraosState slot chainDepState) = encodeVersion serialisationFormatVersion1 $ mconcat [ CBOR.encodeListLen 2 @@ -358,7 +358,7 @@ data instance Ticked (TPraosState c) = TickedChainDepState { , tickedTPraosStateLedgerView :: Ticked (LedgerView (TPraos c)) } -instance TPraosCrypto c => ConsensusProtocol (TPraos c) where +instance PraosCrypto c => ConsensusProtocol (TPraos c) where type ChainDepState (TPraos c) = TPraosState c type IsLeader (TPraos c) = TPraosIsLeader c type CanBeLeader (TPraos c) = TPraosCanBeLeader c @@ -476,7 +476,7 @@ mkShelleyGlobals epochInfo TPraosParams {..} = SL.Globals { -- | Check whether this node meets the leader threshold to issue a block. meetsLeaderThreshold :: - forall c. TPraosCrypto c + forall c. PraosCrypto c => ConsensusConfig (TPraos c) -> LedgerView (TPraos c) -> SL.KeyHash 'SL.StakePool c @@ -523,7 +523,7 @@ data TPraosCannotForge c = !(SL.Hash c (SL.VerKeyVRF c)) deriving (Generic) -deriving instance TPraosCrypto c => Show (TPraosCannotForge c) +deriving instance PraosCrypto c => Show (TPraosCannotForge c) tpraosCheckCanForge :: ConsensusConfig (TPraos c) @@ -556,5 +556,5 @@ tpraosCheckCanForge TPraosConfig { tpraosParams } Condense -------------------------------------------------------------------------------} -instance (Condense toSign, TPraosCrypto c) => Condense (TPraosFields c toSign) where +instance (Condense toSign, PraosCrypto 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 9c27358711a..b755eb10d91 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.Shelley.Protocol.Crypto ( - TPraosCrypto + PraosCrypto , StandardCrypto ) where @@ -13,19 +10,7 @@ import Cardano.Crypto.KES.Sum import Cardano.Crypto.VRF.Praos (PraosVRF) import Cardano.Ledger.Crypto (Crypto (..)) -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) - -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 +import Shelley.Spec.Ledger.API (PraosCrypto) data StandardCrypto @@ -36,4 +21,4 @@ instance Crypto StandardCrypto where type HASH StandardCrypto = Blake2b_256 type ADDRHASH StandardCrypto = Blake2b_224 -instance TPraosCrypto StandardCrypto +instance PraosCrypto StandardCrypto From c34ce843766584bc521bbe54c6280b83d5f335bf Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 29 Oct 2020 11:54:14 +0100 Subject: [PATCH 3/4] Shelley: split off Query in a separate module The initial reason for doing this was to reduce the atrocious compile time of the `Ouroboros.Consensus.Shelley.Ledger.Ledger`, 3 min on my machine! Splitting off `Query` didn't help much, that module now takes 2 min 30 sec to compile on my machine. Nevertheless, splitting it off makes sense, even if it doesn't reduce compile time much. --- .../ouroboros-consensus-shelley.cabal | 1 + .../src/Ouroboros/Consensus/Shelley/Ledger.hs | 1 + .../Consensus/Shelley/Ledger/Ledger.hs | 371 +--------------- .../Consensus/Shelley/Ledger/Query.hs | 417 ++++++++++++++++++ 4 files changed, 423 insertions(+), 367 deletions(-) create mode 100644 ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Query.hs diff --git a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal index 18c2bdcecc2..756438144ec 100644 --- a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal +++ b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal @@ -36,6 +36,7 @@ library Ouroboros.Consensus.Shelley.Ledger.Ledger Ouroboros.Consensus.Shelley.Ledger.Mempool Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion + Ouroboros.Consensus.Shelley.Ledger.Query Ouroboros.Consensus.Shelley.Ledger.TPraos Ouroboros.Consensus.Shelley.Node Ouroboros.Consensus.Shelley.Node.Serialisation diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger.hs index 99dc1d60bc9..0b0bc75a45f 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger.hs @@ -9,3 +9,4 @@ import Ouroboros.Consensus.Shelley.Ledger.Integrity as X import Ouroboros.Consensus.Shelley.Ledger.Ledger as X import Ouroboros.Consensus.Shelley.Ledger.Mempool as X import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion as X +import Ouroboros.Consensus.Shelley.Ledger.Query as X 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 5d4191afe4c..41d64f69c4e 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -2,20 +2,15 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -25,12 +20,10 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger ( , ShelleyBasedEra , ShelleyTip (..) , shelleyTipToPoint + , shelleyLedgerTipPoint , ShelleyTransition(..) , LedgerState (..) , Ticked(..) - , Query (..) - , querySupportedVersion - , NonMyopicMemberRewards (..) -- * Ledger config , ShelleyLedgerConfig (..) , shelleyLedgerGenesis @@ -44,10 +37,6 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger ( , decodeShelleyAnnTip , decodeShelleyLedgerState , encodeShelleyLedgerState - , encodeShelleyQuery - , decodeShelleyQuery - , encodeShelleyResult - , decodeShelleyResult , encodeShelleyHeaderState ) where @@ -55,15 +44,9 @@ import Codec.CBOR.Decoding (Decoder) import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) import qualified Codec.CBOR.Encoding as CBOR -import Codec.Serialise (Serialise, decode, encode) +import Codec.Serialise (decode, encode) import Control.Monad.Except import Data.Functor.Identity -import Data.Kind (Type) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import Data.Type.Equality (apply) -import Data.Typeable (Typeable) import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) @@ -71,9 +54,6 @@ import NoThunks.Class (NoThunks (..)) import Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize) import Cardano.Slotting.EpochInfo -import Ouroboros.Network.Block (Serialised (..), decodePoint, - encodePoint, mkSerialised) - import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types import Ouroboros.Consensus.Config @@ -85,25 +65,21 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsProtocol -import Ouroboros.Consensus.Util (ShowProxy (..), (...:), (..:)) +import Ouroboros.Consensus.Util ((...:), (..:)) import Ouroboros.Consensus.Util.CBOR (decodeWithOrigin, encodeWithOrigin) import Ouroboros.Consensus.Util.Versioned import qualified Shelley.Spec.Ledger.API as SL -import qualified Shelley.Spec.Ledger.LedgerState as SL (RewardAccounts) 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.Config -import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion - (ShelleyNodeToClientVersion (..)) import Ouroboros.Consensus.Shelley.Ledger.TPraos () import Ouroboros.Consensus.Shelley.Protocol (MaxMajorProtVer (..), - TPraosState (..), Ticked (TickedPraosLedgerView)) + Ticked (TickedPraosLedgerView)) import Ouroboros.Consensus.Shelley.Protocol.Util (isNewEpoch) {------------------------------------------------------------------------------- @@ -399,227 +375,6 @@ instance HasHardForkHistory (ShelleyBlock era) where hardForkSummary = neverForksHardForkSummary $ shelleyEraParamsNeverHardForks . shelleyLedgerGenesis -{------------------------------------------------------------------------------- - QueryLedger --------------------------------------------------------------------------------} - -newtype NonMyopicMemberRewards era = NonMyopicMemberRewards { - unNonMyopicMemberRewards :: - Map (Either SL.Coin (SL.Credential 'SL.Staking era)) - (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 (EraCrypto era)) - -instance ShelleyBasedEra era => Serialise (NonMyopicMemberRewards era) where - encode = toCBOR . unNonMyopicMemberRewards - decode = NonMyopicMemberRewards <$> fromCBOR - -data instance Query (ShelleyBlock era) :: Type -> Type where - GetLedgerTip :: Query (ShelleyBlock era) (Point (ShelleyBlock era)) - GetEpochNo :: Query (ShelleyBlock era) EpochNo - -- | Calculate the Non-Myopic Pool Member Rewards for a set of - -- credentials. See 'SL.getNonMyopicMemberRewards' - GetNonMyopicMemberRewards - :: Set (Either SL.Coin (SL.Credential 'SL.Staking era)) - -> Query (ShelleyBlock era) (NonMyopicMemberRewards era) - GetCurrentPParams - :: Query (ShelleyBlock era) (SL.PParams era) - GetProposedPParamsUpdates - :: Query (ShelleyBlock era) (SL.ProposedPPUpdates era) - -- | This gets the stake distribution, but not in terms of _active_ stake - -- (which we need for the leader schedule), but rather in terms of _total_ - -- stake, which is relevant for rewards. It is used by the wallet to show - -- saturation levels to the end user. We should consider refactoring this, to - -- an endpoint that provides all the information that the wallet wants about - -- pools, in an extensible fashion. - GetStakeDistribution - :: Query (ShelleyBlock era) (SL.PoolDistr (EraCrypto era)) - GetFilteredUTxO - :: Set (SL.Addr era) - -> Query (ShelleyBlock era) (SL.UTxO era) - GetUTxO - :: Query (ShelleyBlock era) (SL.UTxO era) - - -- | Only for debugging purposes, we don't guarantee binary compatibility. - -- Moreover, it is huge. - DebugEpochState - :: Query (ShelleyBlock era) (SL.EpochState era) - - -- | Wrap the result of the query using CBOR-in-CBOR. - -- - -- For example, when a client is running a different version than the server - -- and it sends a 'DebugEpochState' query, the client's decoder might fail to - -- deserialise the epoch state as it might have changed between the two - -- different versions. The client will then disconnect. - -- - -- By using CBOR-in-CBOR, the client always successfully decodes the outer - -- CBOR layer (so no disconnect) and can then manually try to decode the - -- inner result. When the client's decoder is able to decode the inner - -- result, it has access to the deserialised epoch state. When it fails to - -- decode it, the client can fall back to pretty printing the actual CBOR, - -- which is better than no output at all. - GetCBOR - :: Query (ShelleyBlock era) result - -> Query (ShelleyBlock era) (Serialised result) - - GetFilteredDelegationsAndRewardAccounts - :: Set (SL.Credential 'SL.Staking era) - -> Query (ShelleyBlock era) (Delegations era, SL.RewardAccounts era) - - GetGenesisConfig - :: Query (ShelleyBlock era) (CompactGenesis era) - - -- | Only for debugging purposes, we don't guarantee binary compatibility. - -- Moreover, it is huge. - DebugNewEpochState - :: Query (ShelleyBlock era) (SL.NewEpochState era) - - -- | Only for debugging purposes, we don't guarantee binary compatibility. - DebugChainDepState - :: Query (ShelleyBlock era) (SL.ChainDepState (EraCrypto era)) - -instance Typeable era => ShowProxy (Query (ShelleyBlock era)) where - -instance ShelleyBasedEra era => QueryLedger (ShelleyBlock era) where - answerQuery cfg query ext@(ExtLedgerState ledgerState headerState) = case query of - GetLedgerTip -> shelleyLedgerTipPoint ledgerState - GetEpochNo -> SL.nesEL $ shelleyLedgerState ledgerState - GetNonMyopicMemberRewards creds -> NonMyopicMemberRewards $ - SL.getNonMyopicMemberRewards globals st creds - GetCurrentPParams -> getPParams st - GetProposedPParamsUpdates -> getProposedPPUpdates st - GetStakeDistribution -> SL.poolsByTotalStakeFraction globals st - GetFilteredUTxO addrs -> SL.getFilteredUTxO st addrs - GetUTxO -> SL.getUTxO st - DebugEpochState -> getEpochState st - GetCBOR query' -> mkSerialised (encodeShelleyResult query') $ - answerQuery cfg query' ext - GetFilteredDelegationsAndRewardAccounts creds -> - getFilteredDelegationsAndRewardAccounts - st - creds - GetGenesisConfig -> shelleyLedgerCompactGenesis lcfg - DebugNewEpochState -> st - DebugChainDepState -> tpraosStateChainDepState (headerStateChainDep headerState) - where - lcfg = configLedger $ getExtLedgerCfg cfg - globals = shelleyLedgerGlobals lcfg - st = shelleyLedgerState ledgerState - -instance SameDepIndex (Query (ShelleyBlock era)) where - sameDepIndex GetLedgerTip GetLedgerTip - = Just Refl - sameDepIndex GetLedgerTip _ - = Nothing - sameDepIndex GetEpochNo GetEpochNo - = Just Refl - sameDepIndex GetEpochNo _ - = Nothing - sameDepIndex (GetNonMyopicMemberRewards creds) (GetNonMyopicMemberRewards creds') - | creds == creds' - = Just Refl - | otherwise - = Nothing - sameDepIndex (GetNonMyopicMemberRewards _) _ - = Nothing - sameDepIndex GetCurrentPParams GetCurrentPParams - = Just Refl - sameDepIndex GetCurrentPParams _ - = Nothing - sameDepIndex GetProposedPParamsUpdates GetProposedPParamsUpdates - = Just Refl - sameDepIndex GetProposedPParamsUpdates _ - = Nothing - sameDepIndex GetStakeDistribution GetStakeDistribution - = Just Refl - sameDepIndex GetStakeDistribution _ - = Nothing - sameDepIndex (GetFilteredUTxO addrs) (GetFilteredUTxO addrs') - | addrs == addrs' - = Just Refl - | otherwise - = Nothing - sameDepIndex (GetFilteredUTxO _) _ - = Nothing - sameDepIndex GetUTxO GetUTxO - = Just Refl - sameDepIndex GetUTxO _ - = Nothing - sameDepIndex DebugEpochState DebugEpochState - = Just Refl - sameDepIndex DebugEpochState _ - = Nothing - sameDepIndex (GetCBOR q) (GetCBOR q') - = apply Refl <$> sameDepIndex q q' - sameDepIndex (GetCBOR _) _ - = Nothing - sameDepIndex (GetFilteredDelegationsAndRewardAccounts creds) - (GetFilteredDelegationsAndRewardAccounts creds') - | creds == creds' - = Just Refl - | otherwise - = Nothing - sameDepIndex (GetFilteredDelegationsAndRewardAccounts _) _ - = Nothing - sameDepIndex GetGenesisConfig GetGenesisConfig - = Just Refl - sameDepIndex GetGenesisConfig _ - = Nothing - sameDepIndex DebugNewEpochState DebugNewEpochState - = Just Refl - sameDepIndex DebugNewEpochState _ - = Nothing - sameDepIndex DebugChainDepState DebugChainDepState - = Just Refl - sameDepIndex DebugChainDepState _ - = Nothing - -deriving instance Eq (Query (ShelleyBlock era) result) -deriving instance Show (Query (ShelleyBlock era) result) - -instance ShelleyBasedEra era => ShowQuery (Query (ShelleyBlock era)) where - showResult = \case - GetLedgerTip -> show - GetEpochNo -> show - GetNonMyopicMemberRewards {} -> show - GetCurrentPParams -> show - GetProposedPParamsUpdates -> show - GetStakeDistribution -> show - GetFilteredUTxO {} -> show - GetUTxO -> show - DebugEpochState -> show - GetCBOR {} -> show - GetFilteredDelegationsAndRewardAccounts {} -> show - GetGenesisConfig -> show - DebugNewEpochState -> show - DebugChainDepState -> show - --- | Is the given query supported by the given 'ShelleyNodeToClientVersion'? -querySupportedVersion :: Query (ShelleyBlock era) result -> ShelleyNodeToClientVersion -> Bool -querySupportedVersion = \case - GetLedgerTip -> (>= v1) - GetEpochNo -> (>= v1) - GetNonMyopicMemberRewards {} -> (>= v1) - GetCurrentPParams -> (>= v1) - GetProposedPParamsUpdates -> (>= v1) - GetStakeDistribution -> (>= v1) - GetFilteredUTxO {} -> (>= v1) - GetUTxO -> (>= v1) - DebugEpochState -> (>= v1) - GetCBOR q -> querySupportedVersion q - GetFilteredDelegationsAndRewardAccounts {} -> (>= v1) - GetGenesisConfig -> (>= v2) - DebugNewEpochState -> (>= v2) - DebugChainDepState -> (>= v2) - where - v1 = ShelleyNodeToClientVersion1 - v2 = ShelleyNodeToClientVersion2 - instance ShelleyBasedEra era => CommonProtocolParams (ShelleyBlock era) where maxHeaderSize = fromIntegral . SL._maxBHSize . getPParams . shelleyLedgerState @@ -648,27 +403,6 @@ instance ShelleyBasedEra era => ValidateEnvelope (ShelleyBlock era) where getPParams :: SL.NewEpochState era -> SL.PParams era getPParams = SL.esPp . SL.nesEs -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. -getEpochState :: SL.NewEpochState era -> SL.EpochState era -getEpochState = SL.nesEs - -getDState :: SL.NewEpochState era -> SL.DState era -getDState = SL._dstate . SL._delegationState . SL.esLState . SL.nesEs - -getFilteredDelegationsAndRewardAccounts :: SL.NewEpochState era - -> Set (SL.Credential 'SL.Staking era) - -> (Delegations era, SL.RewardAccounts era) -getFilteredDelegationsAndRewardAccounts ss creds = - (filteredDelegations, filteredRwdAcnts) - where - SL.DState { _rewards = rewards, _delegations = delegations } = getDState ss - filteredDelegations = Map.restrictKeys delegations creds - filteredRwdAcnts = Map.restrictKeys rewards creds - {------------------------------------------------------------------------------- Serialisation -------------------------------------------------------------------------------} @@ -770,100 +504,3 @@ decodeShelleyLedgerState = decodeVersion [ , shelleyLedgerState , shelleyLedgerTransition } - -encodeShelleyQuery :: - ShelleyBasedEra era - => Query (ShelleyBlock era) result -> Encoding -encodeShelleyQuery query = case query of - GetLedgerTip -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 0 - GetEpochNo -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 1 - GetNonMyopicMemberRewards creds -> - CBOR.encodeListLen 2 <> CBOR.encodeWord8 2 <> toCBOR creds - GetCurrentPParams -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 3 - GetProposedPParamsUpdates -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 4 - GetStakeDistribution -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 5 - GetFilteredUTxO addrs -> - CBOR.encodeListLen 2 <> CBOR.encodeWord8 6 <> toCBOR addrs - GetUTxO -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 7 - DebugEpochState -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 8 - GetCBOR query' -> - CBOR.encodeListLen 2 <> CBOR.encodeWord8 9 <> encodeShelleyQuery query' - GetFilteredDelegationsAndRewardAccounts creds -> - CBOR.encodeListLen 2 <> CBOR.encodeWord8 10 <> toCBOR creds - GetGenesisConfig -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 11 - DebugNewEpochState -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 12 - DebugChainDepState -> - CBOR.encodeListLen 1 <> CBOR.encodeWord8 13 - -decodeShelleyQuery :: - ShelleyBasedEra era - => Decoder s (SomeSecond Query (ShelleyBlock era)) -decodeShelleyQuery = do - len <- CBOR.decodeListLen - tag <- CBOR.decodeWord8 - case (len, tag) of - (1, 0) -> return $ SomeSecond GetLedgerTip - (1, 1) -> return $ SomeSecond GetEpochNo - (2, 2) -> SomeSecond . GetNonMyopicMemberRewards <$> fromCBOR - (1, 3) -> return $ SomeSecond GetCurrentPParams - (1, 4) -> return $ SomeSecond GetProposedPParamsUpdates - (1, 5) -> return $ SomeSecond GetStakeDistribution - (2, 6) -> SomeSecond . GetFilteredUTxO <$> fromCBOR - (1, 7) -> return $ SomeSecond GetUTxO - (1, 8) -> return $ SomeSecond DebugEpochState - (2, 9) -> (\(SomeSecond q) -> SomeSecond (GetCBOR q)) <$> decodeShelleyQuery - (2, 10) -> SomeSecond . GetFilteredDelegationsAndRewardAccounts <$> fromCBOR - (1, 11) -> return $ SomeSecond GetGenesisConfig - (1, 12) -> return $ SomeSecond DebugNewEpochState - (1, 13) -> return $ SomeSecond DebugChainDepState - _ -> fail $ - "decodeShelleyQuery: invalid (len, tag): (" <> - show len <> ", " <> show tag <> ")" - -encodeShelleyResult :: - ShelleyBasedEra era - => Query (ShelleyBlock era) result -> result -> Encoding -encodeShelleyResult query = case query of - GetLedgerTip -> encodePoint encode - GetEpochNo -> encode - GetNonMyopicMemberRewards {} -> encode - GetCurrentPParams -> toCBOR - GetProposedPParamsUpdates -> toCBOR - GetStakeDistribution -> toCBOR - GetFilteredUTxO {} -> toCBOR - GetUTxO -> toCBOR - DebugEpochState -> toCBOR - GetCBOR {} -> encode - GetFilteredDelegationsAndRewardAccounts {} -> toCBOR - GetGenesisConfig -> toCBOR - DebugNewEpochState -> toCBOR - DebugChainDepState -> toCBOR - -decodeShelleyResult :: - ShelleyBasedEra era - => Query (ShelleyBlock era) result - -> forall s. Decoder s result -decodeShelleyResult query = case query of - GetLedgerTip -> decodePoint decode - GetEpochNo -> decode - GetNonMyopicMemberRewards {} -> decode - GetCurrentPParams -> fromCBOR - GetProposedPParamsUpdates -> fromCBOR - GetStakeDistribution -> fromCBOR - GetFilteredUTxO {} -> fromCBOR - GetUTxO -> fromCBOR - DebugEpochState -> fromCBOR - GetCBOR {} -> decode - GetFilteredDelegationsAndRewardAccounts {} -> fromCBOR - GetGenesisConfig -> fromCBOR - DebugNewEpochState -> fromCBOR - DebugChainDepState -> fromCBOR diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Query.hs new file mode 100644 index 00000000000..2580600d39b --- /dev/null +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Ouroboros.Consensus.Shelley.Ledger.Query ( + Query (..) + , querySupportedVersion + , NonMyopicMemberRewards (..) + -- * Serialisation + , encodeShelleyQuery + , decodeShelleyQuery + , encodeShelleyResult + , decodeShelleyResult + ) where + +import Codec.CBOR.Decoding (Decoder) +import qualified Codec.CBOR.Decoding as CBOR +import Codec.CBOR.Encoding (Encoding) +import qualified Codec.CBOR.Encoding as CBOR +import Codec.Serialise (Serialise, decode, encode) +import Data.Kind (Type) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import Data.Type.Equality (apply) +import Data.Typeable (Typeable) + +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) + +import Ouroboros.Network.Block (Serialised (..), decodePoint, + encodePoint, mkSerialised) + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HeaderValidation +import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.Query +import Ouroboros.Consensus.Util (ShowProxy (..)) + +import qualified Shelley.Spec.Ledger.API as SL +import qualified Shelley.Spec.Ledger.LedgerState as SL (RewardAccounts) + +import Ouroboros.Consensus.Shelley.Eras (EraCrypto) +import Ouroboros.Consensus.Shelley.Ledger.Block +import Ouroboros.Consensus.Shelley.Ledger.Config +import Ouroboros.Consensus.Shelley.Ledger.Ledger +import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion + (ShelleyNodeToClientVersion (..)) +import Ouroboros.Consensus.Shelley.Protocol (TPraosState (..)) + +{------------------------------------------------------------------------------- + QueryLedger +-------------------------------------------------------------------------------} + +newtype NonMyopicMemberRewards era = NonMyopicMemberRewards { + unNonMyopicMemberRewards :: + Map (Either SL.Coin (SL.Credential 'SL.Staking era)) + (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 (EraCrypto era)) + +instance ShelleyBasedEra era => Serialise (NonMyopicMemberRewards era) where + encode = toCBOR . unNonMyopicMemberRewards + decode = NonMyopicMemberRewards <$> fromCBOR + +data instance Query (ShelleyBlock era) :: Type -> Type where + GetLedgerTip :: Query (ShelleyBlock era) (Point (ShelleyBlock era)) + GetEpochNo :: Query (ShelleyBlock era) EpochNo + -- | Calculate the Non-Myopic Pool Member Rewards for a set of + -- credentials. See 'SL.getNonMyopicMemberRewards' + GetNonMyopicMemberRewards + :: Set (Either SL.Coin (SL.Credential 'SL.Staking era)) + -> Query (ShelleyBlock era) (NonMyopicMemberRewards era) + GetCurrentPParams + :: Query (ShelleyBlock era) (SL.PParams era) + GetProposedPParamsUpdates + :: Query (ShelleyBlock era) (SL.ProposedPPUpdates era) + -- | This gets the stake distribution, but not in terms of _active_ stake + -- (which we need for the leader schedule), but rather in terms of _total_ + -- stake, which is relevant for rewards. It is used by the wallet to show + -- saturation levels to the end user. We should consider refactoring this, to + -- an endpoint that provides all the information that the wallet wants about + -- pools, in an extensible fashion. + GetStakeDistribution + :: Query (ShelleyBlock era) (SL.PoolDistr (EraCrypto era)) + GetFilteredUTxO + :: Set (SL.Addr era) + -> Query (ShelleyBlock era) (SL.UTxO era) + GetUTxO + :: Query (ShelleyBlock era) (SL.UTxO era) + + -- | Only for debugging purposes, we don't guarantee binary compatibility. + -- Moreover, it is huge. + DebugEpochState + :: Query (ShelleyBlock era) (SL.EpochState era) + + -- | Wrap the result of the query using CBOR-in-CBOR. + -- + -- For example, when a client is running a different version than the server + -- and it sends a 'DebugEpochState' query, the client's decoder might fail to + -- deserialise the epoch state as it might have changed between the two + -- different versions. The client will then disconnect. + -- + -- By using CBOR-in-CBOR, the client always successfully decodes the outer + -- CBOR layer (so no disconnect) and can then manually try to decode the + -- inner result. When the client's decoder is able to decode the inner + -- result, it has access to the deserialised epoch state. When it fails to + -- decode it, the client can fall back to pretty printing the actual CBOR, + -- which is better than no output at all. + GetCBOR + :: Query (ShelleyBlock era) result + -> Query (ShelleyBlock era) (Serialised result) + + GetFilteredDelegationsAndRewardAccounts + :: Set (SL.Credential 'SL.Staking era) + -> Query (ShelleyBlock era) (Delegations era, SL.RewardAccounts era) + + GetGenesisConfig + :: Query (ShelleyBlock era) (CompactGenesis era) + + -- | Only for debugging purposes, we don't guarantee binary compatibility. + -- Moreover, it is huge. + DebugNewEpochState + :: Query (ShelleyBlock era) (SL.NewEpochState era) + + -- | Only for debugging purposes, we don't guarantee binary compatibility. + DebugChainDepState + :: Query (ShelleyBlock era) (SL.ChainDepState (EraCrypto era)) + +instance Typeable era => ShowProxy (Query (ShelleyBlock era)) where + +instance ShelleyBasedEra era => QueryLedger (ShelleyBlock era) where + answerQuery cfg query ext@(ExtLedgerState ledgerState headerState) = + case query of + GetLedgerTip -> + shelleyLedgerTipPoint ledgerState + GetEpochNo -> + SL.nesEL $ shelleyLedgerState ledgerState + GetNonMyopicMemberRewards creds -> + NonMyopicMemberRewards $ + SL.getNonMyopicMemberRewards globals st creds + GetCurrentPParams -> + getPParams st + GetProposedPParamsUpdates -> + getProposedPPUpdates st + GetStakeDistribution -> + SL.poolsByTotalStakeFraction globals st + GetFilteredUTxO addrs -> + SL.getFilteredUTxO st addrs + GetUTxO -> + SL.getUTxO st + DebugEpochState -> + getEpochState st + GetCBOR query' -> + mkSerialised (encodeShelleyResult query') $ + answerQuery cfg query' ext + GetFilteredDelegationsAndRewardAccounts creds -> + getFilteredDelegationsAndRewardAccounts st creds + GetGenesisConfig -> + shelleyLedgerCompactGenesis lcfg + DebugNewEpochState -> + st + DebugChainDepState -> + tpraosStateChainDepState (headerStateChainDep headerState) + where + lcfg = configLedger $ getExtLedgerCfg cfg + globals = shelleyLedgerGlobals lcfg + st = shelleyLedgerState ledgerState + +instance SameDepIndex (Query (ShelleyBlock era)) where + sameDepIndex GetLedgerTip GetLedgerTip + = Just Refl + sameDepIndex GetLedgerTip _ + = Nothing + sameDepIndex GetEpochNo GetEpochNo + = Just Refl + sameDepIndex GetEpochNo _ + = Nothing + sameDepIndex (GetNonMyopicMemberRewards creds) (GetNonMyopicMemberRewards creds') + | creds == creds' + = Just Refl + | otherwise + = Nothing + sameDepIndex (GetNonMyopicMemberRewards _) _ + = Nothing + sameDepIndex GetCurrentPParams GetCurrentPParams + = Just Refl + sameDepIndex GetCurrentPParams _ + = Nothing + sameDepIndex GetProposedPParamsUpdates GetProposedPParamsUpdates + = Just Refl + sameDepIndex GetProposedPParamsUpdates _ + = Nothing + sameDepIndex GetStakeDistribution GetStakeDistribution + = Just Refl + sameDepIndex GetStakeDistribution _ + = Nothing + sameDepIndex (GetFilteredUTxO addrs) (GetFilteredUTxO addrs') + | addrs == addrs' + = Just Refl + | otherwise + = Nothing + sameDepIndex (GetFilteredUTxO _) _ + = Nothing + sameDepIndex GetUTxO GetUTxO + = Just Refl + sameDepIndex GetUTxO _ + = Nothing + sameDepIndex DebugEpochState DebugEpochState + = Just Refl + sameDepIndex DebugEpochState _ + = Nothing + sameDepIndex (GetCBOR q) (GetCBOR q') + = apply Refl <$> sameDepIndex q q' + sameDepIndex (GetCBOR _) _ + = Nothing + sameDepIndex (GetFilteredDelegationsAndRewardAccounts creds) + (GetFilteredDelegationsAndRewardAccounts creds') + | creds == creds' + = Just Refl + | otherwise + = Nothing + sameDepIndex (GetFilteredDelegationsAndRewardAccounts _) _ + = Nothing + sameDepIndex GetGenesisConfig GetGenesisConfig + = Just Refl + sameDepIndex GetGenesisConfig _ + = Nothing + sameDepIndex DebugNewEpochState DebugNewEpochState + = Just Refl + sameDepIndex DebugNewEpochState _ + = Nothing + sameDepIndex DebugChainDepState DebugChainDepState + = Just Refl + sameDepIndex DebugChainDepState _ + = Nothing + +deriving instance Eq (Query (ShelleyBlock era) result) +deriving instance Show (Query (ShelleyBlock era) result) + +instance ShelleyBasedEra era => ShowQuery (Query (ShelleyBlock era)) where + showResult = \case + GetLedgerTip -> show + GetEpochNo -> show + GetNonMyopicMemberRewards {} -> show + GetCurrentPParams -> show + GetProposedPParamsUpdates -> show + GetStakeDistribution -> show + GetFilteredUTxO {} -> show + GetUTxO -> show + DebugEpochState -> show + GetCBOR {} -> show + GetFilteredDelegationsAndRewardAccounts {} -> show + GetGenesisConfig -> show + DebugNewEpochState -> show + DebugChainDepState -> show + +-- | Is the given query supported by the given 'ShelleyNodeToClientVersion'? +querySupportedVersion :: Query (ShelleyBlock era) result -> ShelleyNodeToClientVersion -> Bool +querySupportedVersion = \case + GetLedgerTip -> (>= v1) + GetEpochNo -> (>= v1) + GetNonMyopicMemberRewards {} -> (>= v1) + GetCurrentPParams -> (>= v1) + GetProposedPParamsUpdates -> (>= v1) + GetStakeDistribution -> (>= v1) + GetFilteredUTxO {} -> (>= v1) + GetUTxO -> (>= v1) + DebugEpochState -> (>= v1) + GetCBOR q -> querySupportedVersion q + GetFilteredDelegationsAndRewardAccounts {} -> (>= v1) + GetGenesisConfig -> (>= v2) + DebugNewEpochState -> (>= v2) + DebugChainDepState -> (>= v2) + where + v1 = ShelleyNodeToClientVersion1 + v2 = ShelleyNodeToClientVersion2 + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +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. +getEpochState :: SL.NewEpochState era -> SL.EpochState era +getEpochState = SL.nesEs + +getDState :: SL.NewEpochState era -> SL.DState era +getDState = SL._dstate . SL._delegationState . SL.esLState . SL.nesEs + +getFilteredDelegationsAndRewardAccounts :: SL.NewEpochState era + -> Set (SL.Credential 'SL.Staking era) + -> (Delegations era, SL.RewardAccounts era) +getFilteredDelegationsAndRewardAccounts ss creds = + (filteredDelegations, filteredRwdAcnts) + where + SL.DState { _rewards = rewards, _delegations = delegations } = getDState ss + filteredDelegations = Map.restrictKeys delegations creds + filteredRwdAcnts = Map.restrictKeys rewards creds + +{------------------------------------------------------------------------------- + Serialisation +-------------------------------------------------------------------------------} + +encodeShelleyQuery :: + ShelleyBasedEra era + => Query (ShelleyBlock era) result -> Encoding +encodeShelleyQuery query = case query of + GetLedgerTip -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 0 + GetEpochNo -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 1 + GetNonMyopicMemberRewards creds -> + CBOR.encodeListLen 2 <> CBOR.encodeWord8 2 <> toCBOR creds + GetCurrentPParams -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 3 + GetProposedPParamsUpdates -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 4 + GetStakeDistribution -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 5 + GetFilteredUTxO addrs -> + CBOR.encodeListLen 2 <> CBOR.encodeWord8 6 <> toCBOR addrs + GetUTxO -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 7 + DebugEpochState -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 8 + GetCBOR query' -> + CBOR.encodeListLen 2 <> CBOR.encodeWord8 9 <> encodeShelleyQuery query' + GetFilteredDelegationsAndRewardAccounts creds -> + CBOR.encodeListLen 2 <> CBOR.encodeWord8 10 <> toCBOR creds + GetGenesisConfig -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 11 + DebugNewEpochState -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 12 + DebugChainDepState -> + CBOR.encodeListLen 1 <> CBOR.encodeWord8 13 + +decodeShelleyQuery :: + ShelleyBasedEra era + => Decoder s (SomeSecond Query (ShelleyBlock era)) +decodeShelleyQuery = do + len <- CBOR.decodeListLen + tag <- CBOR.decodeWord8 + case (len, tag) of + (1, 0) -> return $ SomeSecond GetLedgerTip + (1, 1) -> return $ SomeSecond GetEpochNo + (2, 2) -> SomeSecond . GetNonMyopicMemberRewards <$> fromCBOR + (1, 3) -> return $ SomeSecond GetCurrentPParams + (1, 4) -> return $ SomeSecond GetProposedPParamsUpdates + (1, 5) -> return $ SomeSecond GetStakeDistribution + (2, 6) -> SomeSecond . GetFilteredUTxO <$> fromCBOR + (1, 7) -> return $ SomeSecond GetUTxO + (1, 8) -> return $ SomeSecond DebugEpochState + (2, 9) -> (\(SomeSecond q) -> SomeSecond (GetCBOR q)) <$> decodeShelleyQuery + (2, 10) -> SomeSecond . GetFilteredDelegationsAndRewardAccounts <$> fromCBOR + (1, 11) -> return $ SomeSecond GetGenesisConfig + (1, 12) -> return $ SomeSecond DebugNewEpochState + (1, 13) -> return $ SomeSecond DebugChainDepState + _ -> fail $ + "decodeShelleyQuery: invalid (len, tag): (" <> + show len <> ", " <> show tag <> ")" + +encodeShelleyResult :: + ShelleyBasedEra era + => Query (ShelleyBlock era) result -> result -> Encoding +encodeShelleyResult query = case query of + GetLedgerTip -> encodePoint encode + GetEpochNo -> encode + GetNonMyopicMemberRewards {} -> encode + GetCurrentPParams -> toCBOR + GetProposedPParamsUpdates -> toCBOR + GetStakeDistribution -> toCBOR + GetFilteredUTxO {} -> toCBOR + GetUTxO -> toCBOR + DebugEpochState -> toCBOR + GetCBOR {} -> encode + GetFilteredDelegationsAndRewardAccounts {} -> toCBOR + GetGenesisConfig -> toCBOR + DebugNewEpochState -> toCBOR + DebugChainDepState -> toCBOR + +decodeShelleyResult :: + ShelleyBasedEra era + => Query (ShelleyBlock era) result + -> forall s. Decoder s result +decodeShelleyResult query = case query of + GetLedgerTip -> decodePoint decode + GetEpochNo -> decode + GetNonMyopicMemberRewards {} -> decode + GetCurrentPParams -> fromCBOR + GetProposedPParamsUpdates -> fromCBOR + GetStakeDistribution -> fromCBOR + GetFilteredUTxO {} -> fromCBOR + GetUTxO -> fromCBOR + DebugEpochState -> fromCBOR + GetCBOR {} -> decode + GetFilteredDelegationsAndRewardAccounts {} -> fromCBOR + GetGenesisConfig -> fromCBOR + DebugNewEpochState -> fromCBOR + DebugChainDepState -> fromCBOR From bfbf85605d812acc0d558836f4c6d09b99595aae Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 29 Oct 2020 12:43:05 +0100 Subject: [PATCH 4/4] Shelley: reduce the compile time of answerQuery dramatically Before this change, it took 2m30s to compile `Ouroboros.Consensus.Shelley.Ledger.Query` on my machine. After, mere seconds. --- .../Consensus/Shelley/Ledger/Query.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Query.hs index 2580600d39b..d77b3dc4c6c 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -144,12 +144,12 @@ data instance Query (ShelleyBlock era) :: Type -> Type where instance Typeable era => ShowProxy (Query (ShelleyBlock era)) where instance ShelleyBasedEra era => QueryLedger (ShelleyBlock era) where - answerQuery cfg query ext@(ExtLedgerState ledgerState headerState) = + answerQuery cfg query ext = case query of GetLedgerTip -> - shelleyLedgerTipPoint ledgerState + shelleyLedgerTipPoint lst GetEpochNo -> - SL.nesEL $ shelleyLedgerState ledgerState + SL.nesEL st GetNonMyopicMemberRewards creds -> NonMyopicMemberRewards $ SL.getNonMyopicMemberRewards globals st creds @@ -175,11 +175,20 @@ instance ShelleyBasedEra era => QueryLedger (ShelleyBlock era) where DebugNewEpochState -> st DebugChainDepState -> - tpraosStateChainDepState (headerStateChainDep headerState) + tpraosStateChainDepState (headerStateChainDep hst) where lcfg = configLedger $ getExtLedgerCfg cfg globals = shelleyLedgerGlobals lcfg - st = shelleyLedgerState ledgerState + -- NOTE: we are not pattern matching on @ext@ but using the accessors + -- here. The reason for that is that that pattern match blows up the + -- compile time (in particular the time spent desugaring, which is when + -- the compiler looks at pattern matches) to 2m30s! We don't really + -- understand why, but our guess is that it has to do with the combination + -- of the strictness of 'ExtLedgerState', the fact that @LedgerState@ is a + -- data family, and the 'ShelleyBasedEra' constraint. + lst = ledgerState ext + hst = headerState ext + st = shelleyLedgerState lst instance SameDepIndex (Query (ShelleyBlock era)) where sameDepIndex GetLedgerTip GetLedgerTip