Fix query leadership-schedule for current on Babbage.

IntersectMBO · Jun 30, 2022 · cfe0475 · cfe0475
1 parent 111bab0
commit cfe0475
Show file tree

Hide file tree

Showing 2 changed files with 88 additions and 76 deletions.
diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs
@@ -87,23 +87,22 @@ import qualified Data.Yaml as Yaml
 import           Formatting.Buildable (build)
 import           GHC.Records (HasField (..))
 import           System.FilePath
+import           Control.State.Transition
+import           Data.Map.Strict (Map)
+import           Network.TypedProtocol.Pipelined (Nat (..))
 
 import           Cardano.Api.Block
 import           Cardano.Api.Certificate
 import           Cardano.Api.Eras
 import           Cardano.Api.Error
-import           Cardano.Api.IPC (ConsensusModeParams (..),
-                   LocalChainSyncClient (LocalChainSyncClientPipelined),
-                   LocalNodeClientProtocols (..), LocalNodeClientProtocolsInMode,
-                   LocalNodeConnectInfo (..), connectToLocalNode)
+import           Cardano.Api.IPC (ConsensusModeParams (..), LocalChainSyncClient (LocalChainSyncClientPipelined), LocalNodeClientProtocols (..), LocalNodeClientProtocolsInMode, LocalNodeConnectInfo (..), connectToLocalNode)
 import           Cardano.Api.KeysPraos
 import           Cardano.Api.LedgerEvent (LedgerEvent, toLedgerEvent)
-import           Cardano.Api.Modes (CardanoMode, EpochSlots (..))
 import qualified Cardano.Api.Modes as Api
+import           Cardano.Api.Modes (CardanoMode, EpochSlots (..))
 import           Cardano.Api.NetworkId (NetworkId (..), NetworkMagic (NetworkMagic))
 import           Cardano.Api.ProtocolParameters
-import           Cardano.Api.Query (CurrentEpochState (..), ProtocolState,
-                   SerialisedCurrentEpochState (..), decodeCurrentEpochState, decodeProtocolState)
+import           Cardano.Api.Query (CurrentEpochState (..), ProtocolState, SerialisedCurrentEpochState (..), decodeCurrentEpochState, decodeProtocolState)
 import           Cardano.Binary (DecoderError, FromCBOR)
 import qualified Cardano.Chain.Genesis
 import qualified Cardano.Chain.Update
@@ -113,25 +112,27 @@ import qualified Cardano.Crypto.Hash.Class
 import qualified Cardano.Crypto.Hashing
 import qualified Cardano.Crypto.ProtocolMagic
 import qualified Cardano.Crypto.VRF as Crypto
+import qualified Cardano.Crypto.VRF.Class as VRF
 import           Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..))
-import qualified Cardano.Ledger.BHeaderView as Ledger
-import           Cardano.Ledger.BaseTypes (Globals (..), UnitInterval, (⭒))
 import qualified Cardano.Ledger.BaseTypes as Shelley.Spec
+import           Cardano.Ledger.BaseTypes (Globals (..), Nonce, UnitInterval, (⭒))
+import qualified Cardano.Ledger.BHeaderView as Ledger
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Credential as Shelley.Spec
+import qualified Cardano.Ledger.Era
 import qualified Cardano.Ledger.Era as Ledger
 import qualified Cardano.Ledger.Keys as Shelley.Spec
-import qualified Cardano.Ledger.PoolDistr as Ledger
+import qualified Cardano.Ledger.Keys as SL
+import qualified Cardano.Ledger.PoolDistr as SL
 import qualified Cardano.Ledger.Shelley.API as ShelleyAPI
 import qualified Cardano.Ledger.Shelley.Genesis as Shelley.Spec
 import qualified Cardano.Protocol.TPraos.API as TPraos
 import qualified Cardano.Protocol.TPraos.BHeader as TPraos
+import           Cardano.Protocol.TPraos.BHeader (checkLeaderNatValue)
 import           Cardano.Slotting.EpochInfo (EpochInfo)
 import qualified Cardano.Slotting.EpochInfo.API as Slot
-import           Cardano.Slotting.Slot (WithOrigin (At, Origin))
 import qualified Cardano.Slotting.Slot as Slot
-import           Control.State.Transition
-import           Network.TypedProtocol.Pipelined (Nat (..))
+import           Cardano.Slotting.Slot (WithOrigin (At, Origin))
 import qualified Ouroboros.Consensus.Block.Abstract as Consensus
 import qualified Ouroboros.Consensus.Byron.Ledger.Block as Byron
 import qualified Ouroboros.Consensus.Cardano as Consensus
@@ -148,7 +149,9 @@ import qualified Ouroboros.Consensus.Ledger.Extended as Ledger
 import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
 import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus
 import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus
+import           Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ConsensusProtocol (..))
 import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus
+import           Ouroboros.Consensus.Protocol.Praos.VRF (mkInputVRF, vrfLeaderValue)
 import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos
 import qualified Ouroboros.Consensus.Shelley.Eras as Shelley
 import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Shelley
@@ -160,8 +163,6 @@ import qualified Ouroboros.Network.Block
 import qualified Ouroboros.Network.Protocol.ChainSync.Client as CS
 import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as CSP
 import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision
-import Cardano.Ledger.BaseTypes (Nonce)
-import Ouroboros.Consensus.Protocol.Abstract (ChainDepState)
 
 data InitialLedgerStateError
   = ILSEConfigFile Text
@@ -1312,7 +1313,7 @@ nextEpochEligibleLeadershipSlots
   :: forall era.
      HasField "_d" (Core.PParams (ShelleyLedgerEra era)) UnitInterval
   => Ledger.Era (ShelleyLedgerEra era)
-  => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Ledger.Crypto (ShelleyLedgerEra era)))
+  => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Cardano.Ledger.Era.Crypto (ShelleyLedgerEra era)))
   => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era))
   => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era)
   => ShelleyBasedEra era
@@ -1329,14 +1330,11 @@ nextEpochEligibleLeadershipSlots
   -> EpochInfo (Either Text)
   -> (ChainTip, EpochNo)
   -> Either LeadershipError (Set SlotNo)
-nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState
-                 poolid@(StakePoolKeyHash poolHash) (VrfSigningKey vrfSkey) pParams
-                 eInfo (cTip, currentEpoch) = do
-
+nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (VrfSigningKey vrfSkey) pParams eInfo (cTip, currentEpoch) = do
   (_, currentEpochLastSlot) <- first LeaderErrSlotRangeCalculationFailure
                                  $ Slot.epochInfoRange eInfo currentEpoch
 
-  rOfInterest <- first LeaderErrSlotRangeCalculationFailure
+  (firstSlotOfEpoch, lastSlotofEpoch) <- first LeaderErrSlotRangeCalculationFailure
                   $ Slot.epochInfoRange eInfo (currentEpoch + 1)
 
 
@@ -1382,14 +1380,21 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState
                                  $ obtainDecodeEpochStateConstraints sbe
                                  $ decodeCurrentEpochState serCurrEpochState
 
-  let markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr . ShelleyAPI._pstakeMark
+  let markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto)
+      markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr . ShelleyAPI._pstakeMark
                                 $ obtainIsStandardCrypto sbe $ ShelleyAPI.esSnapshots cEstate
 
+  let slotRangeOfInterest = Set.filter
+        (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (toLedgerPParams sbe pParams)))
+        $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] 
 
-  relativeStake <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid)
-                         (Right . ShelleyAPI.individualPoolStake) $ Map.lookup poolHash markSnapshotPoolDistr
+  case sbe of
+    ShelleyBasedEraShelley  -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f
+    ShelleyBasedEraAllegra  -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f
+    ShelleyBasedEraMary     -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f
+    ShelleyBasedEraAlonzo   -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f
+    ShelleyBasedEraBabbage  -> isLeadingSlotsPraos  slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f
 
-  return $ isLeadingSlots sbe rOfInterest nextEpochsNonce pParams vrfSkey relativeStake f
  where
   globals = constructGlobals sGen eInfo pParams
 
@@ -1413,49 +1418,53 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState
 -- See Leader Value Calculation in the Shelley ledger specification.
 -- We need the certified natural value from the VRF, active slot coefficient
 -- and the stake proportion of the stake pool.
-isLeadingSlots :: forall v era. ()
+isLeadingSlotsTPraos :: forall v. ()
   => Crypto.Signable v Shelley.Spec.Seed
   => Crypto.VRFAlgorithm v
   => Crypto.ContextVRF v ~ ()
-  => HasField "_d" (Core.PParams (ShelleyLedgerEra era)) UnitInterval
-  => ShelleyBasedEra era
-  -> (SlotNo, SlotNo) -- ^ Slot range of interest
+  => Set SlotNo
+  -> PoolId
+  -> Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto)
   -> Consensus.Nonce
-  -> ProtocolParameters
   -> Crypto.SignKeyVRF v
-  -> Rational -- ^ Stake pool relative stake
   -> Shelley.Spec.ActiveSlotCoeff
-  -> Set SlotNo
-isLeadingSlots sbe (firstSlotOfEpoch, lastSlotofEpoch) eNonce pParams vrfSkey
-             stakePoolStake activeSlotCoeff' =
-  let certified :: SlotNo -> Crypto.OutputVRF v
-      certified s = certifiedNaturalValue s eNonce vrfSkey
-
-      pp :: Core.PParams (ShelleyLedgerEra era)
-      pp = toLedgerPParams sbe pParams
-
-      slotRangeOfInterest :: Set SlotNo
-      slotRangeOfInterest = Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch]
-
-      isLeader :: SlotNo -> Bool
-      isLeader s = not (Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" pp) s)
-                 && TPraos.checkLeaderValue (certified s)
-                                            stakePoolStake activeSlotCoeff'
-  in Set.filter isLeader slotRangeOfInterest
- where
-  certifiedNaturalValue
-    :: SlotNo
-    -> Consensus.Nonce
-    -> Crypto.SignKeyVRF v
-    -> Crypto.OutputVRF v
-  certifiedNaturalValue slot epochNonce vrfSkey' =
-   Crypto.certifiedOutput
-   $ Crypto.evalCertified () (TPraos.mkSeed TPraos.seedL slot epochNonce) vrfSkey'
+  -> Either LeadershipError (Set SlotNo)
+isLeadingSlotsTPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey activeSlotCoeff' = do
+  let StakePoolKeyHash poolHash = poolid
+
+  let certifiedVrf s = Crypto.evalCertified () (TPraos.mkSeed TPraos.seedL s eNonce) vrfSkey
+
+  stakePoolStake <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid) Right $
+    ShelleyAPI.individualPoolStake <$> Map.lookup poolHash snapshotPoolDistr
+
+  let isLeader s = TPraos.checkLeaderValue (Crypto.certifiedOutput (certifiedVrf s)) stakePoolStake activeSlotCoeff'
+
+  return $ Set.filter isLeader slotRangeOfInterest
+
+isLeadingSlotsPraos :: ()
+  => Set SlotNo
+  -> PoolId
+  -> Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto)
+  -> Consensus.Nonce
+  -> SL.SignKeyVRF Shelley.StandardCrypto
+  -> Shelley.Spec.ActiveSlotCoeff
+  -> Either LeadershipError (Set SlotNo)
+isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey activeSlotCoeff' = do
+  let StakePoolKeyHash poolHash = poolid
+
+  stakePoolStake <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid) Right $
+    ShelleyAPI.individualPoolStake <$> Map.lookup poolHash snapshotPoolDistr
+
+  let isLeader slotNo = checkLeaderNatValue certifiedNatValue stakePoolStake activeSlotCoeff'
+        where rho = VRF.evalCertified () (mkInputVRF slotNo eNonce) vrfSkey
+              certifiedNatValue = vrfLeaderValue (Proxy @Shelley.StandardCrypto) rho
+
+  Right $ Set.filter isLeader slotRangeOfInterest
 
 obtainIsStandardCrypto
   :: ShelleyLedgerEra era ~ ledgerera
   => ShelleyBasedEra era
-  -> (Ledger.Crypto ledgerera ~ Shelley.StandardCrypto => a)
+  -> (Cardano.Ledger.Era.Crypto ledgerera ~ Shelley.StandardCrypto => a)
   -> a
 obtainIsStandardCrypto ShelleyBasedEraShelley f = f
 obtainIsStandardCrypto ShelleyBasedEraAllegra f = f
@@ -1486,7 +1495,7 @@ currentEpochEligibleLeadershipSlots :: forall era ledgerera. ()
   => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era)
   => HasField "_d" (Core.PParams ledgerera) UnitInterval
   -- => Crypto.Signable (Crypto.VRF (Ledger.Crypto ledgerera)) Shelley.Spec.Seed
-  => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Ledger.Crypto (ShelleyLedgerEra era)))
+  => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Cardano.Ledger.Era.Crypto (ShelleyLedgerEra era)))
  -- => Ledger.Crypto ledgerera ~ Shelley.StandardCrypto
   => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era))
   -- => Consensus.ChainDepState (ConsensusProtocol era) ~ Consensus.ChainDepState (ConsensusProtocol era)
@@ -1500,9 +1509,7 @@ currentEpochEligibleLeadershipSlots :: forall era ledgerera. ()
   -> SerialisedCurrentEpochState era
   -> EpochNo -- ^ Current EpochInfo
   -> Either LeadershipError (Set SlotNo)
-currentEpochEligibleLeadershipSlots sbe sGen eInfo pParams ptclState
-                        poolid@(StakePoolKeyHash poolHash) (VrfSigningKey vrkSkey)
-                        serCurrEpochState currentEpoch = do
+currentEpochEligibleLeadershipSlots sbe sGen eInfo pParams ptclState poolid (VrfSigningKey vrkSkey) serCurrEpochState currentEpoch = do
 
   chainDepState :: ChainDepState (Api.ConsensusProtocol era) <-
     first LeaderErrDecodeProtocolStateFailure $ decodeProtocolState ptclState
@@ -1512,7 +1519,7 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo pParams ptclState
   -- at the start of the epoch.
   let epochNonce :: Nonce = Consensus.epochNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState)
 
-  currentEpochRange :: (SlotNo, SlotNo) <- first LeaderErrSlotRangeCalculationFailure
+  (firstSlotOfEpoch, lastSlotofEpoch) :: (SlotNo, SlotNo) <- first LeaderErrSlotRangeCalculationFailure
     $ Slot.epochInfoRange eInfo currentEpoch
 
   CurrentEpochState (cEstate :: ShelleyAPI.EpochState (ShelleyLedgerEra era)) <-
@@ -1522,16 +1529,21 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo pParams ptclState
 
   -- We need the "set" stake distribution (distribution of the previous epoch)
   -- in order to calculate the leadership schedule of the current epoch.
-  let setSnapshotPoolDistr :: Map.Map (ShelleyAPI.KeyHash 'ShelleyAPI.StakePool Shelley.StandardCrypto) (Ledger.IndividualPoolStake Shelley.StandardCrypto)
+  let setSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto)
       setSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr
                                 . ShelleyAPI._pstakeSet . obtainIsStandardCrypto sbe
                                 $ ShelleyAPI.esSnapshots cEstate
 
-  relativeStake :: Rational <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid)
-                         (Right . ShelleyAPI.individualPoolStake)
-                         (Map.lookup poolHash setSnapshotPoolDistr)
+  let slotRangeOfInterest = Set.filter
+        (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (toLedgerPParams sbe pParams)))
+        $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] 
 
-  Right $ isLeadingSlots sbe currentEpochRange epochNonce pParams vrkSkey relativeStake f
+  case sbe of
+    ShelleyBasedEraShelley -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f
+    ShelleyBasedEraAllegra -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f
+    ShelleyBasedEraMary -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f
+    ShelleyBasedEraAlonzo -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f
+    ShelleyBasedEraBabbage -> isLeadingSlotsPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f
 
  where
   globals = constructGlobals sGen eInfo pParams

diff --git a/cardano-testnet/test/Spec/Cli/Babbage/LeadershipSchedule.hs b/cardano-testnet/test/Spec/Cli/Babbage/LeadershipSchedule.hs
@@ -123,8 +123,8 @@ hprop_leadershipSchedule = H.integration . H.runFinallies . H.workspace "alonzo"
 
   let poolVrfSkey = TR.poolNodeKeysVrfSkey $ TR.poolNodeKeys poolNode1
 
-  id $ do
-    currentScheduleFile <- H.noteTempFile tempAbsPath "schedule.log"
+  id do
+    scheduleFile <- H.noteTempFile tempAbsPath "schedule.log"
 
     leadershipScheduleDeadline <- H.noteShowM $ DTC.addUTCTime 180 <$> H.noteShowIO DTC.getCurrentTime
 
@@ -135,11 +135,11 @@ hprop_leadershipSchedule = H.integration . H.runFinallies . H.workspace "alonzo"
         , "--genesis", TC.shelleyGenesisFile tr
         , "--stake-pool-id", stakePoolId
         , "--vrf-signing-key-file", poolVrfSkey
-        , "--out-file", currentScheduleFile
+        , "--out-file", scheduleFile
         , "--current"
         ]
 
-    scheduleJson <- H.leftFailM $ H.readJsonFile currentScheduleFile
+    scheduleJson <- H.leftFailM $ H.readJsonFile scheduleFile
 
     expectedLeadershipSlotNumbers <- H.noteShowM $ fmap (fmap slotNumber) $ H.leftFail $ J.parseEither (J.parseJSON @[LeadershipSlot]) scheduleJson
 
@@ -164,8 +164,8 @@ hprop_leadershipSchedule = H.integration . H.runFinallies . H.workspace "alonzo"
     -- Current leadership schedule matches reality
     H.assert $ L.length (expectedLeadershipSlotNumbers \\ leaderSlots) <= 1
 
-  id $ do
-    currentScheduleFile <- H.noteTempFile tempAbsPath "schedule.log"
+  id do
+    scheduleFile <- H.noteTempFile tempAbsPath "schedule.log"
 
     leadershipScheduleDeadline <- H.noteShowM $ DTC.addUTCTime 180 <$> H.noteShowIO DTC.getCurrentTime
 
@@ -176,11 +176,11 @@ hprop_leadershipSchedule = H.integration . H.runFinallies . H.workspace "alonzo"
         , "--genesis", TC.shelleyGenesisFile tr
         , "--stake-pool-id", stakePoolId
         , "--vrf-signing-key-file", poolVrfSkey
-        , "--out-file", currentScheduleFile
+        , "--out-file", scheduleFile
         , "--next"
         ]
 
-    scheduleJson <- H.leftFailM $ H.readJsonFile currentScheduleFile
+    scheduleJson <- H.leftFailM $ H.readJsonFile scheduleFile
 
     expectedLeadershipSlotNumbers <- H.noteShowM $ fmap (fmap slotNumber) $ H.leftFail $ J.parseEither (J.parseJSON @[LeadershipSlot]) scheduleJson