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

Commit

Permalink
Merge #4077
Browse files Browse the repository at this point in the history 
4077: [CBR-482] Implement OBFT block creation/generation r=intricate a=intricate

## Description

Implementation of block generation/creation for the `OBFT` era.

## Linked issues

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



Co-authored-by: Luke Nadur <luke.nadur@iohk.io>
Co-authored-by: Michael Hueschen <michael.hueschen@iohk.io>
Co-authored-by: Erik de Castro Lopo <erikd@mega-nerd.com>
Co-authored-by: Luke Nadur <19835357+intricate@users.noreply.github.com>
  • Loading branch information
@iohk-bors @intricate @erikd
5 people committed Feb 22, 2019
2 parents 1c8b414 + ccacf63 commit 5f73f4e
Show file tree
Hide file tree
Showing 12 changed files with 330 additions and 105 deletions.
2 changes: 2 additions & 0 deletions CHANGELOG.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,6 +42,8 @@
- Disable SSC during OBFT. ([CBR-490](https://iohk.myjetbrains.com/youtrack/issue/CBR-490) [#4026](https://github.com/input-output-hk/cardano-sl/pull/4026))
- Implement OBFT block validation ([CBR-481](https://iohk.myjetbrains.com/youtrack/issue/CBR-481) [#4018](https://github.com/input-output-hk/cardano-sl/pull/4018) [#4029](https://github.com/input-output-hk/cardano-sl/pull/4029) [#4059](https://github.com/input-output-hk/cardano-sl/pull/4059))
- Add cluster-level tests for OBFT using `script-runner` ([CBR-503](https://iohk.myjetbrains.com/youtrack/issue/CBR-503): [#4061](https://github.com/input-output-hk/cardano-sl/pull/4061) [#4073](https://github.com/input-output-hk/cardano-sl/pull/4073))
- Improve block validation tests ([CBR-504](https://iohk.myjetbrains.com/youtrack/issue/CBR-504) [#4081](https://github.com/input-output-hk/cardano-sl/pull/4081))
- Implement OBFT block creation ([CBR-482](https://iohk.myjetbrains.com/youtrack/issue/CBR-481) [#4077](https://github.com/input-output-hk/cardano-sl/pull/4077))

### Improvements

Expand Down
17 changes: 13 additions & 4 deletions chain/src/Pos/Chain/Block/Slog/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -63,10 +63,19 @@ type LastBlkSlots = OldestFirst [] LastSlotInfo
noLastBlkSlots :: LastBlkSlots
noLastBlkSlots = OldestFirst []

data ConsensusEraLeaders = OriginalLeaders SlotLeaders
| ObftStrictLeaders SlotLeaders
| ObftLenientLeaders (Set StakeholderId) BlockCount LastBlkSlots
deriving (Eq, Show, Generic)
-- | This data type is used for block verification. It specifies which slot
-- leader verification algorithm to use and the parameters required to do so.
data ConsensusEraLeaders
-- | A follow-the-satoshi slot leader schedule for some epoch.
= OriginalLeaders SlotLeaders
-- | An OBFT round-robin slot leader schedule for some epoch.
| ObftStrictLeaders SlotLeaders
-- | A 'Set' of acceptable slot leaders for some epoch, the value of k,
-- and the last k blocks which have been minted.
-- We need to specify k since it's not guaranteed that 'LastBlkSlots' is
-- of length k.
| ObftLenientLeaders (Set StakeholderId) BlockCount LastBlkSlots
deriving (Eq, Show, Generic)

instance NFData ConsensusEraLeaders

Expand Down
67 changes: 45 additions & 22 deletions db/src/Pos/DB/Block/Lrc.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,7 @@ import Pos.Chain.Lrc (LrcError (..), RichmenStakes,
findDelegationStakes, findRichmenStakes,
followTheSatoshiM)
import Pos.Chain.Ssc (MonadSscMem, noReportNoSecretsForEpoch1)
import Pos.Chain.Update (BlockVersionState (..))
import Pos.Chain.Update (BlockVersionState (..), ConsensusEra (..))
import Pos.Core (Coin, EpochIndex (..), EpochOrSlot (..), SharedSeed,
SlotCount, StakeholderId, crucialSlot, epochIndexL,
getEpochOrSlot)
Expand All @@ -54,7 +54,7 @@ import Pos.DB.Lrc (IssuersStakes, LrcConsumer (..), LrcContext (..),
import qualified Pos.DB.Lrc as LrcDB (hasLeaders, putLeadersForEpoch)
import Pos.DB.Ssc (sscCalculateSeed)
import qualified Pos.DB.Txp.Stakes as GS
import Pos.DB.Update (getCompetingBVStates)
import Pos.DB.Update (getCompetingBVStates, getConsensusEra)
import Pos.Util (maybeThrow)
import Pos.Util.Util (HasLens (..), intords)
import Pos.Util.Wlog (logDebug, logInfo, logWarning)
Expand Down Expand Up @@ -141,6 +141,7 @@ lrcDo
-> [LrcConsumer m]
-> m ()
lrcDo genesisConfig epoch consumers = do
era <- getConsensusEra
blundsUpToGenesis <- DB.loadBlundsFromTipWhile genesisHash upToGenesis
-- If there are blocks from 'epoch' it means that we somehow accepted them
-- before running LRC for 'epoch'. It's very bad.
Expand All @@ -155,26 +156,45 @@ lrcDo genesisConfig epoch consumers = do
blundsToRollback <- DB.loadBlundsFromTipWhile genesisHash whileAfterCrucial
blundsToRollbackNE <-
maybeThrow UnknownBlocksForLrc (atLeastKNewestFirst blundsToRollback)
seed <- sscCalculateSeed (configBlockVersionData genesisConfig) epoch >>= \case
Right s -> do
logInfo $ sformat
("Calculated seed for epoch "%build%" successfully") epoch
return s
Left _ -> do
-- Critical error means that the system is in dangerous state.
-- For now let's consider all errors critical, maybe we'll revise it later.
unless (noReportNoSecretsForEpoch1 && epoch == 1) $ do
whenJustM (view misbehaviorMetrics) $ liftIO .
Metrics.inc . _mmSscFailures
getSeed (epoch - 1) >>=
maybeThrow (CanNotReuseSeedForLrc (epoch - 1))
putSeed epoch seed
-- Roll back to the crucial slot and calculate richmen, etc.
withBlocksRolledBack blundsToRollbackNE $ do
issuersComputationDo epoch
richmenComputationDo epoch consumers
DB.sanityCheckDB $ configGenesisData genesisConfig
leadersComputationDo (configEpochSlots genesisConfig) epoch seed
case era of
Original -> do
seed <- sscCalculateSeed (configBlockVersionData genesisConfig) epoch >>= \case
Right s -> do
logInfo $ sformat
("Calculated seed for epoch "%build%" successfully") epoch
return s
Left _ -> do
-- Critical error means that the system is in dangerous state.
-- For now let's consider all errors critical, maybe we'll revise it later.
unless (noReportNoSecretsForEpoch1 && epoch == 1) $ do
whenJustM (view misbehaviorMetrics) $ liftIO .
Metrics.inc . _mmSscFailures
getSeed (epoch - 1) >>=
maybeThrow (CanNotReuseSeedForLrc (epoch - 1))
putSeed epoch seed
-- Roll back to the crucial slot and calculate richmen, etc.
withBlocksRolledBack blundsToRollbackNE $ do
issuersAndRichmenComputationDo
DB.sanityCheckDB $ configGenesisData genesisConfig
leadersComputationDo (configEpochSlots genesisConfig) epoch seed

OBFT _ -> do
-- During OBFT, we don't need to perform any SSC operations such as
-- calculating the seed for FTS. Also, we don't need to perform any
-- leader schedule computations via `leadersComputationDo` since we
-- follow a strict round-robin schedule for OBFT.
--
-- However, we do need to perform the issuers and richmen
-- computations since update adoption depends on this data being
-- available in the database.
--
-- There is a possibility for the richmen (calculated and stored
-- in the db via `richmenComputationDo`) and the genesis
-- stakeholders (which are utilized for the OBFT schedule) to
-- diverge.
withBlocksRolledBack blundsToRollbackNE $ do
issuersAndRichmenComputationDo
DB.sanityCheckDB $ configGenesisData genesisConfig
where
genesisHash = configGenesisHash genesisConfig
atLeastKNewestFirst :: forall a. NewestFirst [] a -> Maybe (NewestFirst NE a)
Expand All @@ -199,6 +219,9 @@ lrcDo genesisConfig epoch consumers = do
-- LRC computation via rollback is an artificial solution
-- and outer viewers mustn't know about it.
ShouldCallBListener False
issuersAndRichmenComputationDo = do
issuersComputationDo epoch
richmenComputationDo epoch consumers
withBlocksRolledBack blunds =
bracket_ (rollbackBlocksUnsafe genesisConfig bsc scb blunds)
(applyBack (toOldestFirst blunds))
Expand Down
88 changes: 68 additions & 20 deletions db/src/Pos/DB/Update/Logic/Global.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,27 +17,29 @@ import Control.Monad.Except (MonadError, runExceptT)
import Data.Default (Default (def))
import UnliftIO (MonadUnliftIO)

import Pos.Chain.Block (ComponentBlock (..), headerHashG,
headerLeaderKeyL, headerSlotL)
import Pos.Chain.Block (BlockHeader (..), ComponentBlock (..),
headerHashG, headerLeaderKeyL, headerSlotL)
import Pos.Chain.Genesis as Genesis (Config (..),
configBlkSecurityParam)
import Pos.Chain.Update (ApplicationName, BlockVersion,
BlockVersionData, BlockVersionState,
ConfirmedProposalState, MonadPoll, NumSoftwareVersion,
PollModifier (..), PollT, PollVerFailure, ProposalState,
SoftwareVersion (..), USUndo, UpId, UpdateConfiguration,
UpdatePayload, blockVersionL, execPollT, execRollT,
getAdoptedBV, lastKnownBlockVersion,
reportUnexpectedError, runPollT)
ConfirmedProposalState, ConsensusEra (..), MonadPoll,
NumSoftwareVersion, PollModifier (..), PollT,
PollVerFailure, ProposalState, SoftwareVersion (..),
USUndo, UpId, UpdateConfiguration, UpdatePayload,
blockVersionL, execPollT, execRollT, getAdoptedBV,
lastKnownBlockVersion, reportUnexpectedError, runPollT)
import Pos.Core (StakeholderId, addressHash, epochIndexL)
import Pos.Core.Chrono (NE, NewestFirst, OldestFirst)
import Pos.Core.Chrono (NE, NewestFirst, OldestFirst (..))
import Pos.Core.Exception (reportFatalError)
import Pos.Core.Reporting (MonadReporting)
import Pos.Core.Slotting (MonadSlotsData, SlottingData, slottingVar)
import Pos.Core.Slotting (EpochIndex (..), MonadSlotsData,
SlotId (..), SlottingData, slottingVar)
import qualified Pos.DB.BatchOp as DB
import qualified Pos.DB.BlockIndex as DB (getTipHeader)
import qualified Pos.DB.Class as DB
import Pos.DB.Lrc (HasLrcContext)
import Pos.DB.Update.GState (UpdateOp (..))
import Pos.DB.Update.GState (UpdateOp (..), getConsensusEra)
import Pos.DB.Update.Poll.DBPoll (DBPoll, runDBPoll)
import Pos.DB.Update.Poll.Logic.Apply (verifyAndApplyUSPayload)
import Pos.DB.Update.Poll.Logic.Base (canCreateBlockBV)
Expand All @@ -47,7 +49,7 @@ import Pos.DB.Update.Poll.Logic.Softfork (processGenesisBlock,
import Pos.Util.AssertMode (inAssertMode)
import qualified Pos.Util.Modifier as MM
import Pos.Util.Util (HasLens', lensOf)
import Pos.Util.Wlog (WithLogger, modifyLoggerName)
import Pos.Util.Wlog (WithLogger, logDebug, modifyLoggerName)


----------------------------------------------------------------------------
Expand Down Expand Up @@ -175,9 +177,7 @@ usVerifyBlocks genesisConfig verifyAllIsKnown blocks = do
reportUnexpectedError $
processRes <$> run uc (runExceptT action)
where
action = do
lastAdopted <- getAdoptedBV
mapM (verifyBlock genesisConfig lastAdopted verifyAllIsKnown) blocks
action = mapM (verifyBlock genesisConfig verifyAllIsKnown) blocks
run :: UpdateConfiguration -> PollT (DBPoll n) a -> n (a, PollModifier)
run uc = runDBPoll uc . runPollT def
processRes ::
Expand All @@ -186,16 +186,49 @@ usVerifyBlocks genesisConfig verifyAllIsKnown blocks = do
processRes (Left failure, _) = Left failure
processRes (Right undos, modifier) = Right (modifier, undos)

verifyBlock
:: (USGlobalVerifyMode ctx m, MonadPoll m, MonadError PollVerFailure m)
verifyBlock ::
( USGlobalVerifyMode ctx m
, DB.MonadDBRead m
, MonadPoll m
, MonadError PollVerFailure m
)
=> Genesis.Config
-> BlockVersion
-> Bool
-> UpdateBlock
-> m USUndo
verifyBlock genesisConfig _ _ (ComponentBlockGenesis genBlk) =
verifyBlock genesisConfig _ (ComponentBlockGenesis genBlk) =
execRollT $ processGenesisBlock genesisConfig (genBlk ^. epochIndexL)
verifyBlock genesisConfig lastAdopted verifyAllIsKnown (ComponentBlockMain header payload) =
verifyBlock genesisConfig verifyAllIsKnown (ComponentBlockMain header payload) = do
lastAdopted <- do
-- During the `Original` era, `processGenesisBlock` is typically
-- called from `verifyBlock` when provided with a
-- `ComponentBlockGenesis` argument.
--
-- `processGenesisBlock` is responsible for some important
-- operations which are to occur at the epoch boundary such as
-- handling update adoption.
--
-- Since epoch boundary blocks aren't created during OBFT,
-- we must ensure that we call `processGenesisBlock` on epoch
-- boundaries (first slot of a new epoch) such that updates can still
-- be adopted during OBFT.
initialEra <- getConsensusEra
initialBV <- getAdoptedBV
logDebug $ "usVerifyBlocks: era '" <> show initialEra <> "'"
case initialEra of
OBFT _ -> do
logDebug $ "usVerifyBlocks OBFT: Checking whether we're"
<> " on epoch boundary and should attempt update"
let slotId = header ^. headerSlotL
epochIndex = siEpoch slotId
tipHeader <- DB.getTipHeader
whenEpochBoundaryObft epochIndex tipHeader (\ei -> do
logDebug $ "usVerifyBlocks OBFT: We're on epoch boundary. Running processGenesisBlock"
processGenesisBlock genesisConfig ei)
getAdoptedBV

Original -> pure initialBV

execRollT $ do
verifyAndApplyUSPayload
genesisConfig
Expand All @@ -214,6 +247,21 @@ verifyBlock genesisConfig lastAdopted verifyAllIsKnown (ComponentBlockMain heade
(header ^. blockVersionL)
(header ^. headerSlotL)
(header ^. headerHashG)
where
whenEpochBoundaryObft ::
( Applicative m
)
=> EpochIndex
-> BlockHeader
-> (EpochIndex -> m ())
-> m ()
whenEpochBoundaryObft currentEpoch tipHeader actn = do
case tipHeader of
BlockHeaderGenesis _ -> pass
BlockHeaderMain mb ->
if mb ^. epochIndexL /= currentEpoch - 1
then pass
else actn currentEpoch

-- | Checks whether our software can create block according to current
-- global state.
Expand Down
2 changes: 2 additions & 0 deletions infra/src/Pos/Infra/Slotting/Util.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -153,6 +153,8 @@ onNewSlotDo epochSlots withLogging expectedSlotId onsp action = do
curSlot <- waitUntilExpectedSlot

let nextSlot = slotIdSucc epochSlots curSlot
logDebug $ sformat ("onNewSlotDo: curSlot = "%shown) curSlot
logDebug $ sformat ("onNewSlotDo: nextSlot = "%shown) nextSlot
Timestamp curTime <- currentTimeSlotting
Timestamp nextSlotStart <- getSlotStartEmpatically nextSlot
let timeToWait = nextSlotStart - curTime
Expand Down
Loading

0 comments on commit 5f73f4e

Please sign in to comment.