Merge #2627

2627: InspectLedger instance for Shelley r=edsko a=edsko

This PR include #2621 and #2626.

Replaces #2508. 

Co-authored-by: Edsko de Vries <edsko@well-typed.com>

ouroboros-consensus-cardano-test/test/Test/ThreadNet/Cardano.hs

@@ -448,6 +448,7 @@ prop_simple_cardano_convergence TestSetup
                   (coreNodes !! fromIntegral nid)
                   (guard setupByronLowerBound *> Just numByronEpochs)
                   (TriggerHardForkAtVersion shelleyMajorVersion)
+                  (TriggerHardForkAtVersion shelleyMaMajorVersion)
             , mkRekeyM = Nothing
             }
 
@@ -711,12 +712,13 @@ mkProtocolCardanoAndHardForkTxs
   -> Shelley.CoreNode (ShelleyEra c)
      -- Hard fork
   -> Maybe EpochNo
-  -> TriggerHardFork
+  -> TriggerHardFork -- ^ Byron to Shelley
+  -> TriggerHardFork -- ^ Shelley to ShelleyMA
   -> TestNodeInitialization m (CardanoBlock c)
 mkProtocolCardanoAndHardForkTxs
     pbftParams coreNodeId genesisByron generatedSecretsByron propPV
     genesisShelley initialNonce coreNodeShelley
-    mbLowerBound triggerHardFork =
+    mbLowerBound byronTransition shelleyTransition =
     TestNodeInitialization
       { tniCrucialTxs   = crucialTxs
       , tniProtocolInfo = pInfo
@@ -755,7 +757,8 @@ mkProtocolCardanoAndHardForkTxs
         (Just leaderCredentialsShelley)
         -- Hard fork
         mbLowerBound
-        triggerHardFork
+        byronTransition
+        shelleyTransition
 
     -- Byron
 
@@ -813,6 +816,12 @@ byronMajorVersion = 0
 shelleyMajorVersion :: Num a => a
 shelleyMajorVersion = byronMajorVersion + 1
 
+-- | The major protocol version of ShelleyMA in this test
+--
+-- See 'MajorVersionbyronMajorVersion
+shelleyMaMajorVersion :: Num a => a
+shelleyMaMajorVersion = shelleyMajorVersion + 1
+
 -- | The initial minor protocol version of Byron in this test
 --
 -- See 'byronMajorVersion'

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs

@@ -132,7 +132,8 @@ data Protocol (m :: Type -> Type) blk p where
        -- taken place.
        --
        -- The @Nothing@ case is useful for test and possible alternative nets.
-    -> TriggerHardFork
+    -> TriggerHardFork -- ^ Transition from Byron to Shelley
+    -> TriggerHardFork -- ^ Transition from Shelley to ShelleyMA
     -> Protocol m (CardanoBlock StandardCrypto) ProtocolCardano
 
 verifyProtocol :: Protocol m blk p -> (p :~: BlockProtocol blk)
@@ -156,11 +157,11 @@ protocolInfo (ProtocolShelley genesis initialNonce protVer maxMajorPV mbLeaderCr
 protocolInfo (ProtocolCardano
                genesisByron mthr prv swv mbLeaderCredentialsByron
                genesisShelley initialNonce protVer maxMajorPV mbLeaderCredentialsShelley
-               mbLowerBound hardCodedTransition) =
+               mbLowerBound byronTransition shelleyTransition) =
     protocolInfoCardano
       genesisByron mthr prv swv mbLeaderCredentialsByron
       genesisShelley initialNonce protVer maxMajorPV mbLeaderCredentialsShelley
-      mbLowerBound hardCodedTransition
+      mbLowerBound byronTransition shelleyTransition
 
 {-------------------------------------------------------------------------------
   Evidence that we can run all the supported protocols

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ByronHFC.hs

@@ -40,8 +40,8 @@ instance NoHardForks ByronBlock where
       byronEraParamsNeverHardForks (byronGenesisConfig (configBlock cfg))
   toPartialConsensusConfig _ = id
   toPartialLedgerConfig _ cfg = ByronPartialLedgerConfig {
-        byronLedgerConfig = cfg
-      , triggerHardFork   = TriggerHardForkNever
+        byronLedgerConfig    = cfg
+      , byronTriggerHardFork = TriggerHardForkNever
       }
 
 {-------------------------------------------------------------------------------

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs

@@ -56,15 +56,18 @@ import           Ouroboros.Consensus.Protocol.PBFT.State (PBftState)
 import qualified Ouroboros.Consensus.Protocol.PBFT.State as PBftState
 
 import           Ouroboros.Consensus.Shelley.Ledger
+import qualified Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect
 import           Ouroboros.Consensus.Shelley.Node ()
 import           Ouroboros.Consensus.Shelley.Protocol
 
-
 import           Cardano.Ledger.Crypto (ADDRHASH, DSIGN, HASH)
 import qualified Cardano.Ledger.Era as Era
+
 import qualified Shelley.Spec.Ledger.API as SL
 import qualified Shelley.Spec.Ledger.BaseTypes as SL
 import qualified Shelley.Spec.Ledger.ByronTranslation as SL
+import qualified Shelley.Spec.Ledger.Genesis as SL
+import qualified Shelley.Spec.Ledger.PParams as SL
 import qualified Shelley.Spec.Ledger.STS.Prtcl as SL
 import qualified Shelley.Spec.Ledger.STS.Tickn as SL
 
@@ -188,13 +191,59 @@ byronTransition ByronPartialLedgerConfig{..} shelleyMajorVersion state =
     takeAny :: [a] -> Maybe a
     takeAny = listToMaybe
 
+{-------------------------------------------------------------------------------
+  Figure out the transition point for Shelley
+-------------------------------------------------------------------------------}
+
+shelleyTransition ::
+     forall era.
+     PartialLedgerConfig (ShelleyBlock era)
+  -> Word16   -- ^ Next era's major protocol version
+  -> LedgerState (ShelleyBlock era)
+  -> Maybe EpochNo
+shelleyTransition ShelleyPartialLedgerConfig{..}
+                  transitionMajorVersion
+                  state =
+      takeAny
+    . mapMaybe isTransition
+    . Shelley.Inspect.protocolUpdates genesis
+    $ state
+  where
+    ShelleyTransitionInfo{..} = shelleyLedgerTransition state
+
+    -- 'shelleyLedgerConfig' contains a dummy 'EpochInfo' but this does not
+    -- matter for extracting the genesis config
+    genesis :: SL.ShelleyGenesis era
+    genesis = shelleyLedgerGenesis shelleyLedgerConfig
+
+    k :: Word64
+    k = SL.sgSecurityParam genesis
+
+    isTransition :: Shelley.Inspect.ProtocolUpdate era -> Maybe EpochNo
+    isTransition Shelley.Inspect.ProtocolUpdate{..} = do
+         SL.ProtVer major _minor <- proposalVersion
+         guard $ fromIntegral major == transitionMajorVersion
+         guard $ proposalReachedQuorum
+         guard $ shelleyAfterVoting >= fromIntegral k
+         return proposalEpoch
+       where
+         Shelley.Inspect.UpdateProposal{..} = protocolUpdateProposal
+         Shelley.Inspect.UpdateState{..}    = protocolUpdateState
+
+    -- In principle there could be multiple proposals that all change the
+    -- major protocol version. In practice this can't happen because each
+    -- delegate can only vote for one proposal, but the types don't guarantee
+    -- this. We don't need to worry about this, and just pick any of them.
+    takeAny :: [a] -> Maybe a
+    takeAny = listToMaybe
+
 {-------------------------------------------------------------------------------
   SingleEraBlock Byron
 -------------------------------------------------------------------------------}
 
 instance SingleEraBlock ByronBlock where
   singleEraTransition pcfg _eraParams _eraStart ledgerState =
-      case triggerHardFork pcfg of
+      case byronTriggerHardFork pcfg of
         TriggerHardForkNever                         -> Nothing
         TriggerHardForkAtEpoch   epoch               -> Just epoch
         TriggerHardForkAtVersion shelleyMajorVersion ->
@@ -228,8 +277,8 @@ data TriggerHardFork =
 -- condition for the hard fork to Shelley, as we don't have to modify the
 -- ledger config for standalone Byron.
 data ByronPartialLedgerConfig = ByronPartialLedgerConfig {
-      byronLedgerConfig :: !(LedgerConfig ByronBlock)
-    , triggerHardFork   :: !TriggerHardFork
+      byronLedgerConfig    :: !(LedgerConfig ByronBlock)
+    , byronTriggerHardFork :: !TriggerHardFork
     }
   deriving (Generic, NoUnexpectedThunks)
 
@@ -244,8 +293,15 @@ instance HasPartialLedgerConfig ByronBlock where
 -------------------------------------------------------------------------------}
 
 instance TPraosCrypto era => SingleEraBlock (ShelleyBlock era) where
-  -- No transition from Shelley to Goguen yet
-  singleEraTransition _cfg _eraParams _eraStart _st = Nothing
+  singleEraTransition pcfg _eraParams _eraStart ledgerState =
+      case shelleyTriggerHardFork pcfg of
+        TriggerHardForkNever                         -> Nothing
+        TriggerHardForkAtEpoch   epoch               -> Just epoch
+        TriggerHardForkAtVersion shelleyMajorVersion ->
+            shelleyTransition
+              pcfg
+              shelleyMajorVersion
+              ledgerState
 
   singleEraInfo _ = SingleEraInfo {
       singleEraName = "Shelley"
@@ -259,23 +315,24 @@ instance TPraosCrypto era => HasPartialConsensusConfig (TPraos era) where
   -- 'ChainSelConfig' is ()
   partialChainSelConfig _ _ = ()
 
-newtype ShelleyPartialLedgerConfig era = ShelleyPartialLedgerConfig {
+data ShelleyPartialLedgerConfig era = ShelleyPartialLedgerConfig {
       -- | We cache the non-partial ledger config containing a dummy
       -- 'EpochInfo' that needs to be replaced with the correct one.
       --
       -- We do this to avoid recomputing the ledger config each time
       -- 'completeLedgerConfig' is called, as 'mkShelleyLedgerConfig' does
       -- some rather expensive computations that shouldn't be repeated too
       -- often (e.g., 'sgActiveSlotCoeff').
-      getShelleyPartialLedgerConfig :: ShelleyLedgerConfig era
+      shelleyLedgerConfig    :: !(ShelleyLedgerConfig era)
+    , shelleyTriggerHardFork :: !TriggerHardFork
     }
   deriving (Generic, NoUnexpectedThunks)
 
 instance TPraosCrypto era => HasPartialLedgerConfig (ShelleyBlock era) where
   type PartialLedgerConfig (ShelleyBlock era) = ShelleyPartialLedgerConfig era
 
   -- Replace the dummy 'EpochInfo' with the real one
-  completeLedgerConfig _ epochInfo (ShelleyPartialLedgerConfig cfg) =
+  completeLedgerConfig _ epochInfo (ShelleyPartialLedgerConfig cfg _) =
       cfg {
           shelleyLedgerGlobals = (shelleyLedgerGlobals cfg) {
               SL.epochInfo = epochInfo
@@ -362,7 +419,7 @@ translateLedgerStateByronToShelleyWrapper =
             epochNo
             (byronLedgerState ledgerByron)
       , shelleyLedgerTransition =
-          ShelleyTransitionUnknown
+          ShelleyTransitionInfo{shelleyAfterVoting = 0}
       }
 
 translateChainDepStateByronToShelleyWrapper

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs

@@ -275,11 +275,12 @@ protocolInfoCardano
   -> Maybe (TPraosLeaderCredentials (ShelleyEra c))
      -- Hard fork
   -> Maybe EpochNo  -- ^ lower bound on first Shelley epoch
-  -> TriggerHardFork
+  -> TriggerHardFork -- ^ Transition from Byron to Shelley
+  -> TriggerHardFork -- ^ Transition from Shelley to ShelleyMA
   -> ProtocolInfo m (CardanoBlock c)
 protocolInfoCardano genesisByron mSigThresh pVer sVer mbCredsByron
                     genesisShelley initialNonce protVer maxMajorPV mbCredsShelley
-                    mbLowerBound triggerHardFork =
+                    mbLowerBound byronTriggerHardFork shelleyTriggerHardFork =
     assertWithMsg (validateGenesis genesisShelley) $
     ProtocolInfo {
         pInfoConfig = cfg
@@ -314,8 +315,8 @@ protocolInfoCardano genesisByron mSigThresh pVer sVer mbCredsByron
 
     partialLedgerConfigByron :: PartialLedgerConfig ByronBlock
     partialLedgerConfigByron = ByronPartialLedgerConfig {
-          byronLedgerConfig = ledgerConfigByron
-        , triggerHardFork   = triggerHardFork
+          byronLedgerConfig    = ledgerConfigByron
+        , byronTriggerHardFork = byronTriggerHardFork
         }
 
     kByron :: SecurityParam
@@ -346,6 +347,7 @@ protocolInfoCardano genesisByron mSigThresh pVer sVer mbCredsByron
         mkPartialLedgerConfigShelley
           genesisShelley
           maxMajorPV
+          shelleyTriggerHardFork
 
     kShelley :: SecurityParam
     kShelley = SecurityParam $ sgSecurityParam genesisShelley
@@ -455,13 +457,22 @@ ledgerConfigCardano ::
   -> MaxMajorProtVer
 
      -- Hard fork
-  -> TriggerHardFork
-  -> Maybe EpochNo  -- ^ lower bound on first Shelley epoch
+  -> TriggerHardFork -- ^ transition from Byron to Shelley
+  -> Maybe EpochNo   -- ^ lower bound on first Shelley epoch
+  -> TriggerHardFork -- ^ transition from Shelley to ShelleyMA
 
   -> CardanoLedgerConfig c
-ledgerConfigCardano genesisByron
-                    genesisShelley  maxMajorPV
-                    triggerHardFork mbLowerBound =
+ledgerConfigCardano
+    -- Byron
+    genesisByron
+    -- Shelley
+    genesisShelley
+    maxMajorPV
+    -- HFC
+    byronTriggerHardFork
+    mbLowerBound
+    shelleyTriggerHardFork
+  =
     HardForkLedgerConfig {
         hardForkLedgerConfigShape  = shape
       , hardForkLedgerConfigPerEra = PerEraLedgerConfig
@@ -475,8 +486,8 @@ ledgerConfigCardano genesisByron
 
     partialLedgerConfigByron :: PartialLedgerConfig ByronBlock
     partialLedgerConfigByron = ByronPartialLedgerConfig {
-          byronLedgerConfig = genesisByron
-        , triggerHardFork   = triggerHardFork
+          byronLedgerConfig    = genesisByron
+        , byronTriggerHardFork = byronTriggerHardFork
         }
 
     -- Shelley
@@ -486,6 +497,7 @@ ledgerConfigCardano genesisByron
         mkPartialLedgerConfigShelley
           genesisShelley
           maxMajorPV
+          shelleyTriggerHardFork
 
     -- Cardano
 
@@ -502,15 +514,19 @@ ledgerConfigCardano genesisByron
 mkPartialLedgerConfigShelley ::
      ShelleyGenesis (ShelleyEra c)
   -> MaxMajorProtVer
+  -> TriggerHardFork
   -> PartialLedgerConfig (ShelleyBlock (ShelleyEra c))
-mkPartialLedgerConfigShelley genesisShelley maxMajorPV =
-    ShelleyPartialLedgerConfig $
-      Shelley.mkShelleyLedgerConfig
-        genesisShelley
-        -- 'completeLedgerConfig' will replace the 'History.dummyEpochInfo' in
-        -- the partial ledger config with the correct one.
-        History.dummyEpochInfo
-        maxMajorPV
+mkPartialLedgerConfigShelley genesisShelley maxMajorPV shelleyTriggerHardFork =
+    ShelleyPartialLedgerConfig {
+          shelleyLedgerConfig =
+            Shelley.mkShelleyLedgerConfig
+              genesisShelley
+              -- 'completeLedgerConfig' will replace the 'History.dummyEpochInfo'
+              -- in the partial ledger config with the correct one.
+              History.dummyEpochInfo
+              maxMajorPV
+        , shelleyTriggerHardFork = shelleyTriggerHardFork
+        }
 
 {-------------------------------------------------------------------------------
   Helpers

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyHFC.hs

@@ -37,7 +37,10 @@ type ShelleyBlockHFC era = HardForkBlock '[ShelleyBlock era]
 instance TPraosCrypto era => NoHardForks (ShelleyBlock era) where
   getEraParams            cfg = shelleyLedgerEraParams (configLedger cfg)
   toPartialConsensusConfig _  = tpraosParams
-  toPartialLedgerConfig    _  = ShelleyPartialLedgerConfig
+  toPartialLedgerConfig _ cfg = ShelleyPartialLedgerConfig {
+        shelleyLedgerConfig    = cfg
+      , shelleyTriggerHardFork = TriggerHardForkNever
+      }
 
 {-------------------------------------------------------------------------------
   SupportedNetworkProtocolVersion instance

ouroboros-consensus-cardano/tools/db-analyser/Block/Cardano.hs

@@ -96,6 +96,7 @@ mkCardanoProtocolInfo byronConfig shelleyConfig signatureThreshold initialNonce
       Nothing
       Nothing
       (TriggerHardForkAtVersion 2)
+      (TriggerHardForkAtVersion 3)
 
 castHeaderHash ::
      HeaderHash ByronBlock

ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs

@@ -448,7 +448,7 @@ exampleLedgerState = ShelleyLedgerState {
                                   , shelleyTipHash    = blockHash exampleBlock
                                   }
     , shelleyLedgerState      = exampleNewEpochState
-    , shelleyLedgerTransition = ShelleyTransitionUnknown
+    , shelleyLedgerTransition = ShelleyTransitionInfo {shelleyAfterVoting = 0}
     }
 
 exampleHeaderState :: HeaderState (ShelleyBlock StandardShelley)

ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs

@@ -114,10 +114,7 @@ instance CanMock era => Arbitrary (ShelleyTip era) where
     <*> arbitrary
 
 instance Arbitrary ShelleyTransition where
-  arbitrary = oneof [
-        pure ShelleyTransitionUnknown
-        -- TODO: Add case once we implement this type properly (#2471)
-      ]
+  arbitrary = ShelleyTransitionInfo <$> arbitrary
 
 instance CanMock era => Arbitrary (LedgerState (ShelleyBlock era)) where
   arbitrary = ShelleyLedgerState

ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal

@@ -30,6 +30,7 @@ library
                        Ouroboros.Consensus.Shelley.Ledger.Block
                        Ouroboros.Consensus.Shelley.Ledger.Config
                        Ouroboros.Consensus.Shelley.Ledger.Forge
+                       Ouroboros.Consensus.Shelley.Ledger.Inspect
                        Ouroboros.Consensus.Shelley.Ledger.Integrity
                        Ouroboros.Consensus.Shelley.Ledger.Ledger
                        Ouroboros.Consensus.Shelley.Ledger.Mempool