Merge #4029

4029: [CBR-481/482] Add functionality for determining slot leaders during OBFT r=intricate a=intricate

## Description

Adds functionality for determining slot leaders and richmen during the OBFT era. Also adds a test `ObftRoundRobinSpec` which introduces a couple of property tests pertaining to the OBFT round-robin slot leader schedule. 

_Note: This PR does not actually modify block generation or validation code. It only introduces the functions which will be utilized in upcoming PRs._

## Linked issues

https://iohk.myjetbrains.com/youtrack/issue/CBR-481
https://iohk.myjetbrains.com/youtrack/issue/CBR-482



Co-authored-by: Michael Hueschen <[email protected]>
Co-authored-by: Luke Nadur <[email protected]>

Author: 3 people

chain/cardano-sl-chain.cabal

@@ -91,6 +91,7 @@ library
                        Pos.Chain.Txp.Undo
 
                        Pos.Chain.Lrc.Fts
+                       Pos.Chain.Lrc.OBFT
                        Pos.Chain.Lrc.Types
                        Pos.Chain.Lrc.Error
                        Pos.Chain.Lrc.Core
@@ -255,6 +256,8 @@ test-suite chain-test
                        Test.Pos.Chain.Genesis.Gen
                        Test.Pos.Chain.Genesis.Json
                        Test.Pos.Chain.Lrc.FtsSpec
+                       Test.Pos.Chain.Lrc.ObftRoundRobinSpec
+                       Test.Pos.Chain.Lrc.StakeAndHolder
                        Test.Pos.Chain.Ssc.Arbitrary
                        Test.Pos.Chain.Ssc.Bi
                        Test.Pos.Chain.Ssc.CborSpec

chain/src/Pos/Chain/Genesis/Config.hs

@@ -15,6 +15,7 @@ module Pos.Chain.Genesis.Config
        , configEpochSlots
        , configGeneratedSecretsThrow
        , configBootStakeholders
+       , configGenesisWStakeholders
        , configHeavyDelegation
        , configStartTime
        , configVssCerts
@@ -60,11 +61,11 @@ import           Pos.Chain.Genesis.ProtocolConstants
                      (GenesisProtocolConstants (..),
                      genesisProtocolConstantsToProtocolConstants)
 import           Pos.Chain.Genesis.Spec (GenesisSpec (..))
-import           Pos.Chain.Genesis.WStakeholders (GenesisWStakeholders)
+import           Pos.Chain.Genesis.WStakeholders (GenesisWStakeholders (..))
 import           Pos.Chain.Ssc.VssCertificatesMap (VssCertificatesMap)
 import           Pos.Chain.Txp.Tx (TxValidationRulesConfig)
 import           Pos.Chain.Update.BlockVersionData (BlockVersionData)
-import           Pos.Core.Common (BlockCount, SharedSeed)
+import           Pos.Core.Common (BlockCount, SharedSeed, StakeholderId)
 import           Pos.Core.ProtocolConstants (ProtocolConstants (..),
                      pcBlkSecurityParam, pcChainQualityThreshold, pcEpochSlots,
                      pcSlotSecurityParam, vssMaxTTL, vssMinTTL)
@@ -196,6 +197,10 @@ configGeneratedSecretsThrow =
 configBootStakeholders :: Config -> GenesisWStakeholders
 configBootStakeholders = gdBootStakeholders . configGenesisData
 
+configGenesisWStakeholders :: Config -> [StakeholderId]
+configGenesisWStakeholders =
+    keys . getGenesisWStakeholders . configBootStakeholders
+
 configHeavyDelegation :: Config -> GenesisDelegation
 configHeavyDelegation = gdHeavyDelegation . configGenesisData
 

chain/src/Pos/Chain/Lrc.hs

@@ -6,5 +6,6 @@ import           Pos.Chain.Lrc.Core as X
 import           Pos.Chain.Lrc.Error as X
 import           Pos.Chain.Lrc.Fts as X
 import           Pos.Chain.Lrc.Genesis as X
+import           Pos.Chain.Lrc.OBFT as X
 import           Pos.Chain.Lrc.RichmenComponent as X
 import           Pos.Chain.Lrc.Types as X

chain/src/Pos/Chain/Lrc/OBFT.hs

@@ -0,0 +1,55 @@
+module Pos.Chain.Lrc.OBFT
+        ( getSlotLeaderObftPure
+        , getEpochSlotLeaderScheduleObftPure
+        ) where
+
+import           Universum hiding (sort)
+
+import           Data.List.NonEmpty ((!!))
+import qualified Data.List.NonEmpty as NE (iterate, sort, take)
+
+import           Pos.Core (EpochIndex, FlatSlotId, LocalSlotIndex (..),
+                     SlotCount (..), SlotId (..), SlotLeaders, StakeholderId,
+                     flattenEpochOrSlot, slotIdSucc)
+
+-- | Selects the StakeholderId that matches the @SlotId@ index in a
+-- @SlotCount@-length epoch.
+getSlotLeaderObftPure
+    :: SlotId
+    -> SlotCount
+    -> NonEmpty StakeholderId
+    -> StakeholderId
+getSlotLeaderObftPure slotId slotCount stakeholders =
+    sortedStakeholders !! leaderIndex
+  where
+    -- Ensure the stakeholders are sorted
+    sortedStakeholders :: NonEmpty StakeholderId
+    sortedStakeholders = NE.sort stakeholders
+    --
+    leaderIndex :: Int
+    leaderIndex = (fromIntegral flatSlotId :: Int) `mod` (length stakeholders)
+    --
+    flatSlotId :: FlatSlotId
+    flatSlotId = flattenEpochOrSlot slotCount slotId
+
+-- | Selects @SlotCount@ StakeholderIds for the given epoch @EpochIndex@.
+getEpochSlotLeaderScheduleObftPure
+    :: EpochIndex
+    -> SlotCount
+    -> NonEmpty StakeholderId
+    -> SlotLeaders
+getEpochSlotLeaderScheduleObftPure epochIndex epochSlotCount stakeholders =
+    case nonEmpty slotLeaderSchedule of
+        Just sls -> sls
+        Nothing  -> error "getEpochSlotLeaderScheduleObftPure: Empty slot leader schedule"
+  where
+    slotLeaderSchedule =
+        map (\si -> getSlotLeaderObftPure si epochSlotCount stakeholders)
+            (NE.take (fromIntegral $ numEpochSlots)
+                     (NE.iterate (slotIdSucc epochSlotCount) startSlotId))
+    --
+    startSlotId :: SlotId
+    startSlotId = SlotId epochIndex (UnsafeLocalSlotIndex 0)
+    --
+    numEpochSlots :: Word64
+    numEpochSlots = getSlotCount $ epochSlotCount

chain/test/Test/Pos/Chain/Lrc/FtsSpec.hs

@@ -10,21 +10,19 @@ module Test.Pos.Chain.Lrc.FtsSpec
 
 import           Universum
 
-import           Data.List (scanl1)
-import qualified Data.Set as S (deleteFindMin, fromList)
 import           Test.Hspec (Spec, describe)
 import           Test.Hspec.QuickCheck (modifyMaxSuccess, prop)
-import           Test.QuickCheck (Arbitrary (..), Property, choose,
-                     infiniteListOf, suchThat, (===))
+import           Test.QuickCheck (Arbitrary (..), Property, infiniteListOf,
+                     (===))
 
 import           Pos.Chain.Lrc (followTheSatoshi)
-import           Pos.Core (Coin, SharedSeed, StakeholderId, StakesList,
-                     addressHash, mkCoin, pcK, sumCoins, unsafeAddCoin,
-                     unsafeIntegerToCoin)
+import           Pos.Core (Coin, SharedSeed, StakeholderId, addressHash, pcK,
+                     sumCoins, unsafeIntegerToCoin)
 import           Pos.Crypto (PublicKey)
 
 import           Test.Pos.Chain.Genesis.Dummy (dummyEpochSlots,
                      dummyProtocolConstants)
+import           Test.Pos.Chain.Lrc.StakeAndHolder (StakeAndHolder (..))
 import           Test.Pos.Core.Arbitrary ()
 import           Test.Pos.Util.QuickCheck.Property (qcNotElem)
 
@@ -70,33 +68,6 @@ spec = do
     acceptable present (1 - (1 - highStake) ^ pLen)
       && acceptable chosen highStake
 
--- | Type used to generate random stakes and a 'PublicKey' that
--- doesn't have any stake.
---
--- Two necessarily different public keys are generated, as well as a list of
--- public keys who will be our other stakeholders. To guarantee a non-empty
--- stakes map, one of these public keys is inserted in the list, which is
--- converted to a set and then to a map.
-newtype StakeAndHolder = StakeAndHolder
-    { getNoStake :: (PublicKey, StakesList)
-    } deriving Show
-
-instance Arbitrary StakeAndHolder where
-    arbitrary = StakeAndHolder <$> do
-        pk1 <- arbitrary
-        pk2 <- arbitrary `suchThat` ((/=) pk1)
-        listPks <- do
-            n <- choose (2, 10)
-            replicateM n arbitrary
-        coins <- mkCoin <$> choose (1, 1000)
-        let setPks :: Set PublicKey
-            setPks = S.fromList $ pk1 : pk2 : listPks
-            (myPk, restPks) = S.deleteFindMin setPks
-            nRest = length restPks
-            values = scanl1 unsafeAddCoin $ replicate nRest coins
-            stakesList = map addressHash (toList restPks) `zip` values
-        return (myPk, stakesList)
-
 ftsListLength
     :: SharedSeed
     -> StakeAndHolder

chain/test/Test/Pos/Chain/Lrc/ObftRoundRobinSpec.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Specification of Pos.Chain.Lrc.OBFT (which is basically a pure
+-- version of 'Pos.DB.Lrc.OBFT').
+
+module Test.Pos.Chain.Lrc.ObftRoundRobinSpec
+       ( spec
+       ) where
+
+import           Universum hiding (sort)
+
+import           Data.List.NonEmpty (sort, (!!))
+import           Test.Hspec (Spec, describe)
+import           Test.Hspec.QuickCheck (modifyMaxSuccess, prop)
+import           Test.QuickCheck (Property, (===))
+
+import           Pos.Chain.Lrc (getEpochSlotLeaderScheduleObftPure,
+                     getSlotLeaderObftPure)
+import           Pos.Core (EpochIndex, SlotCount, SlotId, flattenEpochOrSlot)
+
+import           Test.Pos.Chain.Lrc.StakeAndHolder (StakeAndHolder (..))
+import           Test.Pos.Core.Arbitrary (genPositiveSlotCount)
+
+spec :: Spec
+spec = do
+  describe "Pos.Chain.Lrc.OBFT" $ do
+    describe "Round-robin" $ do
+        modifyMaxSuccess (const 10000) $ do
+            prop description_rrListLength
+                 (rrListLength <$> genPositiveSlotCount)
+            prop description_rrCorrectSlotLeader
+                 (rrCorrectSlotLeader <$> genPositiveSlotCount)
+ where
+  description_rrListLength =
+    "the amount of stakeholders is the same as the number of slots in an epoch"
+  description_rrCorrectSlotLeader =
+    "the correct slot leader is chosen given any epoch and slot"
+
+rrListLength
+    :: SlotCount
+    -> EpochIndex
+    -> StakeAndHolder
+    -> Property
+rrListLength epochSlotCount epochIndex (getNoStake -> (_, stakes)) = do
+    length (getEpochSlotLeaderScheduleObftPure epochIndex epochSlotCount stakeholders)
+        === fromIntegral epochSlotCount
+  where
+    stakeholders = case nonEmpty (map fst stakes) of
+        Just s  -> s
+        Nothing -> error "rrListLength: Empty list of stakeholders"
+
+rrCorrectSlotLeader
+    :: SlotCount
+    -> SlotId
+    -> StakeAndHolder
+    -> Property
+rrCorrectSlotLeader epochSlotCount slotId (getNoStake -> (_, stakes)) = do
+    actualSlotLeader === expectedSlotLeader
+  where
+    stakeholders = case nonEmpty (map fst stakes) of
+        Just s  -> s
+        Nothing -> error "rrCorrectSlotLeader: Empty list of stakeholders"
+    flatSlotId = flattenEpochOrSlot epochSlotCount slotId
+    expectedSlotLeaderIndex =
+        (fromIntegral flatSlotId :: Int) `mod` (length stakeholders)
+    expectedSlotLeader = (sort stakeholders) !! expectedSlotLeaderIndex
+    actualSlotLeader = getSlotLeaderObftPure slotId epochSlotCount stakeholders

chain/test/Test/Pos/Chain/Lrc/StakeAndHolder.hs

@@ -0,0 +1,41 @@
+module Test.Pos.Chain.Lrc.StakeAndHolder
+       ( StakeAndHolder (..)
+       ) where
+
+import           Universum
+
+import           Data.List (scanl1)
+import qualified Data.Set as S (deleteFindMin, fromList)
+import           Test.QuickCheck (Arbitrary (..), choose, suchThat)
+
+import           Pos.Core (StakesList, addressHash, mkCoin, unsafeAddCoin)
+import           Pos.Crypto (PublicKey)
+
+import           Test.Pos.Core.Arbitrary ()
+
+-- | Type used to generate random stakes and a 'PublicKey' that
+-- doesn't have any stake.
+--
+-- Two necessarily different public keys are generated, as well as a list of
+-- public keys who will be our other stakeholders. To guarantee a non-empty
+-- stakes map, one of these public keys is inserted in the list, which is
+-- converted to a set and then to a map.
+newtype StakeAndHolder = StakeAndHolder
+    { getNoStake :: (PublicKey, StakesList)
+    } deriving Show
+
+instance Arbitrary StakeAndHolder where
+    arbitrary = StakeAndHolder <$> do
+        pk1 <- arbitrary
+        pk2 <- arbitrary `suchThat` ((/=) pk1)
+        listPks <- do
+            n <- choose (2, 10)
+            replicateM n arbitrary
+        coins <- mkCoin <$> choose (1, 1000)
+        let setPks :: Set PublicKey
+            setPks = S.fromList $ pk1 : pk2 : listPks
+            (myPk, restPks) = S.deleteFindMin setPks
+            nRest = length restPks
+            values = scanl1 unsafeAddCoin $ replicate nRest coins
+            stakesList = map addressHash (toList restPks) `zip` values
+        return (myPk, stakesList)

core/test/Test/Pos/Core/Arbitrary.hs

@@ -20,6 +20,7 @@ module Test.Pos.Core.Arbitrary
        , UnreasonableEoS (..)
 
        , genAddress
+       , genPositiveSlotCount
        , genSlotId
        , genLocalSlotIndex
        ) where
@@ -99,6 +100,12 @@ deriving instance Arbitrary ChainDifficulty
 
 deriving instance Arbitrary SlotCount
 
+genPositiveSlotCount :: Gen SlotCount
+genPositiveSlotCount = do
+    let upperBound = 5000 -- no specific reason for using 5000
+    x <- choose (1, upperBound)
+    pure $ SlotCount x
+
 maxReasonableEpoch :: Integral a => a
 maxReasonableEpoch = 5 * 1000 * 1000 * 1000 * 1000  -- 5 * 10^12, because why not
 

db/cardano-sl-db.cabal

@@ -39,6 +39,7 @@ library
                        Pos.DB.Txp.Utxo
 
                        Pos.DB.Lrc
+                       Pos.DB.Lrc.OBFT
                        Pos.DB.Delegation
                        Pos.DB.Ssc
                        Pos.DB.Ssc.SecretStorage

db/src/Pos/DB/Lrc/Consumer/Delegation.hs

@@ -13,10 +13,15 @@ module Pos.DB.Lrc.Consumer.Delegation
        -- * Functions for getting richmen
        , getDlgRichmen
        , tryGetDlgRichmen
+       , getDlgRichmenObft
        ) where
 
 import           Universum
 
+import           Data.HashSet (fromList)
+
+import           Pos.Chain.Genesis (configGenesisWStakeholders)
+import           Pos.Chain.Genesis as Genesis (Config (..))
 import           Pos.Chain.Lrc (RichmenComponent (..), RichmenSet)
 import           Pos.Chain.Update (BlockVersionData (..))
 import           Pos.Core (EpochIndex)
@@ -70,3 +75,10 @@ getDlgRichmen genesisBvd fname epoch = lrcActionOnEpochReason
 tryGetDlgRichmen
     :: MonadDBRead m => BlockVersionData -> EpochIndex -> m (Maybe RichmenSet)
 tryGetDlgRichmen = getRichmen . dlgRichmenComponent
+
+-- | For OBFT, we retrieve the genesis stakeholders and classify them as the
+-- "richmen". We don't perform any LRC operations here.
+getDlgRichmenObft
+    :: Genesis.Config
+    -> RichmenSet
+getDlgRichmenObft = fromList . configGenesisWStakeholders

db/src/Pos/DB/Lrc/OBFT.hs

@@ -0,0 +1,57 @@
+module Pos.DB.Lrc.OBFT
+       ( getSlotLeaderObft
+       , getEpochSlotLeaderScheduleObft
+       ) where
+
+import           Universum
+
+import           Pos.Chain.Delegation (ProxySKBlockInfo)
+import           Pos.Chain.Genesis (configGenesisWStakeholders)
+import qualified Pos.Chain.Genesis as Genesis (Config (..))
+import           Pos.Chain.Lrc (getEpochSlotLeaderScheduleObftPure,
+                     getSlotLeaderObftPure)
+import           Pos.Core (EpochIndex, SlotCount (..), SlotId (..), SlotLeaders,
+                     StakeholderId, pcEpochSlots)
+import           Pos.DB (MonadDBRead)
+import           Pos.DB.Delegation (getDlgTransPsk)
+
+import           UnliftIO (MonadUnliftIO)
+
+-- | This function selects the current slot leaders by obtaining the
+-- genesis stakeholders, then tracing them through the delegation
+-- mapping.
+getSlotLeaderObft
+    :: (MonadDBRead m, MonadUnliftIO m)
+    => Genesis.Config -> SlotId -> m (StakeholderId, ProxySKBlockInfo)
+getSlotLeaderObft genesisConfig si = do
+    mDlg <- getDlgTransPsk currentSlotGenesisSId
+    pure (currentSlotGenesisSId, (swap <$> mDlg))
+  where
+    -- We assume here that the genesis bootstrap stakeholders list
+    -- is nonempty
+    stakeholders :: [StakeholderId]
+    stakeholders = sort $ configGenesisWStakeholders genesisConfig
+    --
+    epochSlotCount :: SlotCount
+    epochSlotCount =
+        pcEpochSlots (Genesis.configProtocolConstants genesisConfig)
+    --
+    currentSlotGenesisSId :: StakeholderId
+    currentSlotGenesisSId =
+        case (nonEmpty stakeholders) of
+            Just s  -> getSlotLeaderObftPure si epochSlotCount s
+            Nothing -> error "getSlotLeaderObft: Empty list of stakeholders"
+
+-- | Generates the full slot leader schedule for an epoch (10*k slots long).
+getEpochSlotLeaderScheduleObft
+    :: Genesis.Config -> EpochIndex -> SlotLeaders
+getEpochSlotLeaderScheduleObft genesisConfig ei =
+    case nonEmpty stakeholders of
+        Just s  -> getEpochSlotLeaderScheduleObftPure ei epochSlotCount s
+        Nothing -> error "getEpochSlotLeaderScheduleObft: Empty list of stakeholders"
+  where
+    -- We assume here that the genesis bootstrap stakeholders list
+    -- is nonempty
+    stakeholders :: [StakeholderId]
+    stakeholders = sort $ configGenesisWStakeholders genesisConfig
+    epochSlotCount = pcEpochSlots (Genesis.configProtocolConstants genesisConfig)