Skip to content
This repository was archived by the owner on Aug 18, 2020. It is now read-only.

Commit 66b0dd9

Browse files
iohk-bors[bot]Michael HueschenintricateKtorZ
committed
Merge #4029 #4050
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 4050: Internal Endpoints Disclaimer r=KtorZ a=KtorZ ## Description <!--- A brief description of this PR and the problem is trying to solve --> As a follow-up from the discussion in cardano-foundation/cardano-wallet#151 (comment), we will add a proper disclaimer in the documentation about the internal endpoints. ## Linked issue <!--- Put here the relevant issue from YouTrack --> cardano-foundation/cardano-wallet#228 Co-authored-by: Michael Hueschen <[email protected]> Co-authored-by: Luke Nadur <[email protected]> Co-authored-by: KtorZ <[email protected]>
3 parents a3e37e1 + c61f195 + 3e2e167 commit 66b0dd9

File tree

21 files changed

+324
-67
lines changed

21 files changed

+324
-67
lines changed

‎chain/cardano-sl-chain.cabal

+3
Original file line numberDiff line numberDiff line change
@@ -91,6 +91,7 @@ library
9191
Pos.Chain.Txp.Undo
9292

9393
Pos.Chain.Lrc.Fts
94+
Pos.Chain.Lrc.OBFT
9495
Pos.Chain.Lrc.Types
9596
Pos.Chain.Lrc.Error
9697
Pos.Chain.Lrc.Core
@@ -255,6 +256,8 @@ test-suite chain-test
255256
Test.Pos.Chain.Genesis.Gen
256257
Test.Pos.Chain.Genesis.Json
257258
Test.Pos.Chain.Lrc.FtsSpec
259+
Test.Pos.Chain.Lrc.ObftRoundRobinSpec
260+
Test.Pos.Chain.Lrc.StakeAndHolder
258261
Test.Pos.Chain.Ssc.Arbitrary
259262
Test.Pos.Chain.Ssc.Bi
260263
Test.Pos.Chain.Ssc.CborSpec

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

+7-2
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ module Pos.Chain.Genesis.Config
1515
, configEpochSlots
1616
, configGeneratedSecretsThrow
1717
, configBootStakeholders
18+
, configGenesisWStakeholders
1819
, configHeavyDelegation
1920
, configStartTime
2021
, configVssCerts
@@ -60,11 +61,11 @@ import Pos.Chain.Genesis.ProtocolConstants
6061
(GenesisProtocolConstants (..),
6162
genesisProtocolConstantsToProtocolConstants)
6263
import Pos.Chain.Genesis.Spec (GenesisSpec (..))
63-
import Pos.Chain.Genesis.WStakeholders (GenesisWStakeholders)
64+
import Pos.Chain.Genesis.WStakeholders (GenesisWStakeholders (..))
6465
import Pos.Chain.Ssc.VssCertificatesMap (VssCertificatesMap)
6566
import Pos.Chain.Txp.Tx (TxValidationRulesConfig)
6667
import Pos.Chain.Update.BlockVersionData (BlockVersionData)
67-
import Pos.Core.Common (BlockCount, SharedSeed)
68+
import Pos.Core.Common (BlockCount, SharedSeed, StakeholderId)
6869
import Pos.Core.ProtocolConstants (ProtocolConstants (..),
6970
pcBlkSecurityParam, pcChainQualityThreshold, pcEpochSlots,
7071
pcSlotSecurityParam, vssMaxTTL, vssMinTTL)
@@ -196,6 +197,10 @@ configGeneratedSecretsThrow =
196197
configBootStakeholders :: Config -> GenesisWStakeholders
197198
configBootStakeholders = gdBootStakeholders . configGenesisData
198199

200+
configGenesisWStakeholders :: Config -> [StakeholderId]
201+
configGenesisWStakeholders =
202+
keys . getGenesisWStakeholders . configBootStakeholders
203+
199204
configHeavyDelegation :: Config -> GenesisDelegation
200205
configHeavyDelegation = gdHeavyDelegation . configGenesisData
201206

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

+1
Original file line numberDiff line numberDiff line change
@@ -6,5 +6,6 @@ import Pos.Chain.Lrc.Core as X
66
import Pos.Chain.Lrc.Error as X
77
import Pos.Chain.Lrc.Fts as X
88
import Pos.Chain.Lrc.Genesis as X
9+
import Pos.Chain.Lrc.OBFT as X
910
import Pos.Chain.Lrc.RichmenComponent as X
1011
import Pos.Chain.Lrc.Types as X

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

+55
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,55 @@
1+
module Pos.Chain.Lrc.OBFT
2+
( getSlotLeaderObftPure
3+
, getEpochSlotLeaderScheduleObftPure
4+
) where
5+
6+
import Universum hiding (sort)
7+
8+
import Data.List.NonEmpty ((!!))
9+
import qualified Data.List.NonEmpty as NE (iterate, sort, take)
10+
11+
import Pos.Core (EpochIndex, FlatSlotId, LocalSlotIndex (..),
12+
SlotCount (..), SlotId (..), SlotLeaders, StakeholderId,
13+
flattenEpochOrSlot, slotIdSucc)
14+
15+
-- | Selects the StakeholderId that matches the @SlotId@ index in a
16+
-- @SlotCount@-length epoch.
17+
getSlotLeaderObftPure
18+
:: SlotId
19+
-> SlotCount
20+
-> NonEmpty StakeholderId
21+
-> StakeholderId
22+
getSlotLeaderObftPure slotId slotCount stakeholders =
23+
sortedStakeholders !! leaderIndex
24+
where
25+
-- Ensure the stakeholders are sorted
26+
sortedStakeholders :: NonEmpty StakeholderId
27+
sortedStakeholders = NE.sort stakeholders
28+
--
29+
leaderIndex :: Int
30+
leaderIndex = (fromIntegral flatSlotId :: Int) `mod` (length stakeholders)
31+
--
32+
flatSlotId :: FlatSlotId
33+
flatSlotId = flattenEpochOrSlot slotCount slotId
34+
35+
-- | Selects @SlotCount@ StakeholderIds for the given epoch @EpochIndex@.
36+
getEpochSlotLeaderScheduleObftPure
37+
:: EpochIndex
38+
-> SlotCount
39+
-> NonEmpty StakeholderId
40+
-> SlotLeaders
41+
getEpochSlotLeaderScheduleObftPure epochIndex epochSlotCount stakeholders =
42+
case nonEmpty slotLeaderSchedule of
43+
Just sls -> sls
44+
Nothing -> error "getEpochSlotLeaderScheduleObftPure: Empty slot leader schedule"
45+
where
46+
slotLeaderSchedule =
47+
map (\si -> getSlotLeaderObftPure si epochSlotCount stakeholders)
48+
(NE.take (fromIntegral $ numEpochSlots)
49+
(NE.iterate (slotIdSucc epochSlotCount) startSlotId))
50+
--
51+
startSlotId :: SlotId
52+
startSlotId = SlotId epochIndex (UnsafeLocalSlotIndex 0)
53+
--
54+
numEpochSlots :: Word64
55+
numEpochSlots = getSlotCount $ epochSlotCount

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

+5-34
Original file line numberDiff line numberDiff line change
@@ -10,21 +10,19 @@ module Test.Pos.Chain.Lrc.FtsSpec
1010

1111
import Universum
1212

13-
import Data.List (scanl1)
14-
import qualified Data.Set as S (deleteFindMin, fromList)
1513
import Test.Hspec (Spec, describe)
1614
import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)
17-
import Test.QuickCheck (Arbitrary (..), Property, choose,
18-
infiniteListOf, suchThat, (===))
15+
import Test.QuickCheck (Arbitrary (..), Property, infiniteListOf,
16+
(===))
1917

2018
import Pos.Chain.Lrc (followTheSatoshi)
21-
import Pos.Core (Coin, SharedSeed, StakeholderId, StakesList,
22-
addressHash, mkCoin, pcK, sumCoins, unsafeAddCoin,
23-
unsafeIntegerToCoin)
19+
import Pos.Core (Coin, SharedSeed, StakeholderId, addressHash, pcK,
20+
sumCoins, unsafeIntegerToCoin)
2421
import Pos.Crypto (PublicKey)
2522

2623
import Test.Pos.Chain.Genesis.Dummy (dummyEpochSlots,
2724
dummyProtocolConstants)
25+
import Test.Pos.Chain.Lrc.StakeAndHolder (StakeAndHolder (..))
2826
import Test.Pos.Core.Arbitrary ()
2927
import Test.Pos.Util.QuickCheck.Property (qcNotElem)
3028

@@ -70,33 +68,6 @@ spec = do
7068
acceptable present (1 - (1 - highStake) ^ pLen)
7169
&& acceptable chosen highStake
7270

73-
-- | Type used to generate random stakes and a 'PublicKey' that
74-
-- doesn't have any stake.
75-
--
76-
-- Two necessarily different public keys are generated, as well as a list of
77-
-- public keys who will be our other stakeholders. To guarantee a non-empty
78-
-- stakes map, one of these public keys is inserted in the list, which is
79-
-- converted to a set and then to a map.
80-
newtype StakeAndHolder = StakeAndHolder
81-
{ getNoStake :: (PublicKey, StakesList)
82-
} deriving Show
83-
84-
instance Arbitrary StakeAndHolder where
85-
arbitrary = StakeAndHolder <$> do
86-
pk1 <- arbitrary
87-
pk2 <- arbitrary `suchThat` ((/=) pk1)
88-
listPks <- do
89-
n <- choose (2, 10)
90-
replicateM n arbitrary
91-
coins <- mkCoin <$> choose (1, 1000)
92-
let setPks :: Set PublicKey
93-
setPks = S.fromList $ pk1 : pk2 : listPks
94-
(myPk, restPks) = S.deleteFindMin setPks
95-
nRest = length restPks
96-
values = scanl1 unsafeAddCoin $ replicate nRest coins
97-
stakesList = map addressHash (toList restPks) `zip` values
98-
return (myPk, stakesList)
99-
10071
ftsListLength
10172
:: SharedSeed
10273
-> StakeAndHolder

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

+67
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,67 @@
1+
{-# LANGUAGE ViewPatterns #-}
2+
3+
-- | Specification of Pos.Chain.Lrc.OBFT (which is basically a pure
4+
-- version of 'Pos.DB.Lrc.OBFT').
5+
6+
module Test.Pos.Chain.Lrc.ObftRoundRobinSpec
7+
( spec
8+
) where
9+
10+
import Universum hiding (sort)
11+
12+
import Data.List.NonEmpty (sort, (!!))
13+
import Test.Hspec (Spec, describe)
14+
import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)
15+
import Test.QuickCheck (Property, (===))
16+
17+
import Pos.Chain.Lrc (getEpochSlotLeaderScheduleObftPure,
18+
getSlotLeaderObftPure)
19+
import Pos.Core (EpochIndex, SlotCount, SlotId, flattenEpochOrSlot)
20+
21+
import Test.Pos.Chain.Lrc.StakeAndHolder (StakeAndHolder (..))
22+
import Test.Pos.Core.Arbitrary (genPositiveSlotCount)
23+
24+
spec :: Spec
25+
spec = do
26+
describe "Pos.Chain.Lrc.OBFT" $ do
27+
describe "Round-robin" $ do
28+
modifyMaxSuccess (const 10000) $ do
29+
prop description_rrListLength
30+
(rrListLength <$> genPositiveSlotCount)
31+
prop description_rrCorrectSlotLeader
32+
(rrCorrectSlotLeader <$> genPositiveSlotCount)
33+
where
34+
description_rrListLength =
35+
"the amount of stakeholders is the same as the number of slots in an epoch"
36+
description_rrCorrectSlotLeader =
37+
"the correct slot leader is chosen given any epoch and slot"
38+
39+
rrListLength
40+
:: SlotCount
41+
-> EpochIndex
42+
-> StakeAndHolder
43+
-> Property
44+
rrListLength epochSlotCount epochIndex (getNoStake -> (_, stakes)) = do
45+
length (getEpochSlotLeaderScheduleObftPure epochIndex epochSlotCount stakeholders)
46+
=== fromIntegral epochSlotCount
47+
where
48+
stakeholders = case nonEmpty (map fst stakes) of
49+
Just s -> s
50+
Nothing -> error "rrListLength: Empty list of stakeholders"
51+
52+
rrCorrectSlotLeader
53+
:: SlotCount
54+
-> SlotId
55+
-> StakeAndHolder
56+
-> Property
57+
rrCorrectSlotLeader epochSlotCount slotId (getNoStake -> (_, stakes)) = do
58+
actualSlotLeader === expectedSlotLeader
59+
where
60+
stakeholders = case nonEmpty (map fst stakes) of
61+
Just s -> s
62+
Nothing -> error "rrCorrectSlotLeader: Empty list of stakeholders"
63+
flatSlotId = flattenEpochOrSlot epochSlotCount slotId
64+
expectedSlotLeaderIndex =
65+
(fromIntegral flatSlotId :: Int) `mod` (length stakeholders)
66+
expectedSlotLeader = (sort stakeholders) !! expectedSlotLeaderIndex
67+
actualSlotLeader = getSlotLeaderObftPure slotId epochSlotCount stakeholders

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

+41
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
module Test.Pos.Chain.Lrc.StakeAndHolder
2+
( StakeAndHolder (..)
3+
) where
4+
5+
import Universum
6+
7+
import Data.List (scanl1)
8+
import qualified Data.Set as S (deleteFindMin, fromList)
9+
import Test.QuickCheck (Arbitrary (..), choose, suchThat)
10+
11+
import Pos.Core (StakesList, addressHash, mkCoin, unsafeAddCoin)
12+
import Pos.Crypto (PublicKey)
13+
14+
import Test.Pos.Core.Arbitrary ()
15+
16+
-- | Type used to generate random stakes and a 'PublicKey' that
17+
-- doesn't have any stake.
18+
--
19+
-- Two necessarily different public keys are generated, as well as a list of
20+
-- public keys who will be our other stakeholders. To guarantee a non-empty
21+
-- stakes map, one of these public keys is inserted in the list, which is
22+
-- converted to a set and then to a map.
23+
newtype StakeAndHolder = StakeAndHolder
24+
{ getNoStake :: (PublicKey, StakesList)
25+
} deriving Show
26+
27+
instance Arbitrary StakeAndHolder where
28+
arbitrary = StakeAndHolder <$> do
29+
pk1 <- arbitrary
30+
pk2 <- arbitrary `suchThat` ((/=) pk1)
31+
listPks <- do
32+
n <- choose (2, 10)
33+
replicateM n arbitrary
34+
coins <- mkCoin <$> choose (1, 1000)
35+
let setPks :: Set PublicKey
36+
setPks = S.fromList $ pk1 : pk2 : listPks
37+
(myPk, restPks) = S.deleteFindMin setPks
38+
nRest = length restPks
39+
values = scanl1 unsafeAddCoin $ replicate nRest coins
40+
stakesList = map addressHash (toList restPks) `zip` values
41+
return (myPk, stakesList)

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

+7
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ module Test.Pos.Core.Arbitrary
2020
, UnreasonableEoS (..)
2121

2222
, genAddress
23+
, genPositiveSlotCount
2324
, genSlotId
2425
, genLocalSlotIndex
2526
) where
@@ -99,6 +100,12 @@ deriving instance Arbitrary ChainDifficulty
99100

100101
deriving instance Arbitrary SlotCount
101102

103+
genPositiveSlotCount :: Gen SlotCount
104+
genPositiveSlotCount = do
105+
let upperBound = 5000 -- no specific reason for using 5000
106+
x <- choose (1, upperBound)
107+
pure $ SlotCount x
108+
102109
maxReasonableEpoch :: Integral a => a
103110
maxReasonableEpoch = 5 * 1000 * 1000 * 1000 * 1000 -- 5 * 10^12, because why not
104111

‎db/cardano-sl-db.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ library
3939
Pos.DB.Txp.Utxo
4040

4141
Pos.DB.Lrc
42+
Pos.DB.Lrc.OBFT
4243
Pos.DB.Delegation
4344
Pos.DB.Ssc
4445
Pos.DB.Ssc.SecretStorage

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

+12
Original file line numberDiff line numberDiff line change
@@ -13,10 +13,15 @@ module Pos.DB.Lrc.Consumer.Delegation
1313
-- * Functions for getting richmen
1414
, getDlgRichmen
1515
, tryGetDlgRichmen
16+
, getDlgRichmenObft
1617
) where
1718

1819
import Universum
1920

21+
import Data.HashSet (fromList)
22+
23+
import Pos.Chain.Genesis (configGenesisWStakeholders)
24+
import Pos.Chain.Genesis as Genesis (Config (..))
2025
import Pos.Chain.Lrc (RichmenComponent (..), RichmenSet)
2126
import Pos.Chain.Update (BlockVersionData (..))
2227
import Pos.Core (EpochIndex)
@@ -70,3 +75,10 @@ getDlgRichmen genesisBvd fname epoch = lrcActionOnEpochReason
7075
tryGetDlgRichmen
7176
:: MonadDBRead m => BlockVersionData -> EpochIndex -> m (Maybe RichmenSet)
7277
tryGetDlgRichmen = getRichmen . dlgRichmenComponent
78+
79+
-- | For OBFT, we retrieve the genesis stakeholders and classify them as the
80+
-- "richmen". We don't perform any LRC operations here.
81+
getDlgRichmenObft
82+
:: Genesis.Config
83+
-> RichmenSet
84+
getDlgRichmenObft = fromList . configGenesisWStakeholders

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

+57
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,57 @@
1+
module Pos.DB.Lrc.OBFT
2+
( getSlotLeaderObft
3+
, getEpochSlotLeaderScheduleObft
4+
) where
5+
6+
import Universum
7+
8+
import Pos.Chain.Delegation (ProxySKBlockInfo)
9+
import Pos.Chain.Genesis (configGenesisWStakeholders)
10+
import qualified Pos.Chain.Genesis as Genesis (Config (..))
11+
import Pos.Chain.Lrc (getEpochSlotLeaderScheduleObftPure,
12+
getSlotLeaderObftPure)
13+
import Pos.Core (EpochIndex, SlotCount (..), SlotId (..), SlotLeaders,
14+
StakeholderId, pcEpochSlots)
15+
import Pos.DB (MonadDBRead)
16+
import Pos.DB.Delegation (getDlgTransPsk)
17+
18+
import UnliftIO (MonadUnliftIO)
19+
20+
-- | This function selects the current slot leaders by obtaining the
21+
-- genesis stakeholders, then tracing them through the delegation
22+
-- mapping.
23+
getSlotLeaderObft
24+
:: (MonadDBRead m, MonadUnliftIO m)
25+
=> Genesis.Config -> SlotId -> m (StakeholderId, ProxySKBlockInfo)
26+
getSlotLeaderObft genesisConfig si = do
27+
mDlg <- getDlgTransPsk currentSlotGenesisSId
28+
pure (currentSlotGenesisSId, (swap <$> mDlg))
29+
where
30+
-- We assume here that the genesis bootstrap stakeholders list
31+
-- is nonempty
32+
stakeholders :: [StakeholderId]
33+
stakeholders = sort $ configGenesisWStakeholders genesisConfig
34+
--
35+
epochSlotCount :: SlotCount
36+
epochSlotCount =
37+
pcEpochSlots (Genesis.configProtocolConstants genesisConfig)
38+
--
39+
currentSlotGenesisSId :: StakeholderId
40+
currentSlotGenesisSId =
41+
case (nonEmpty stakeholders) of
42+
Just s -> getSlotLeaderObftPure si epochSlotCount s
43+
Nothing -> error "getSlotLeaderObft: Empty list of stakeholders"
44+
45+
-- | Generates the full slot leader schedule for an epoch (10*k slots long).
46+
getEpochSlotLeaderScheduleObft
47+
:: Genesis.Config -> EpochIndex -> SlotLeaders
48+
getEpochSlotLeaderScheduleObft genesisConfig ei =
49+
case nonEmpty stakeholders of
50+
Just s -> getEpochSlotLeaderScheduleObftPure ei epochSlotCount s
51+
Nothing -> error "getEpochSlotLeaderScheduleObft: Empty list of stakeholders"
52+
where
53+
-- We assume here that the genesis bootstrap stakeholders list
54+
-- is nonempty
55+
stakeholders :: [StakeholderId]
56+
stakeholders = sort $ configGenesisWStakeholders genesisConfig
57+
epochSlotCount = pcEpochSlots (Genesis.configProtocolConstants genesisConfig)

0 commit comments

Comments
 (0)