diff --git a/auxx/src/Command/Tx.hs b/auxx/src/Command/Tx.hs index 7cd6d1add38..cc3c92a997c 100644 --- a/auxx/src/Command/Tx.hs +++ b/auxx/src/Command/Tx.hs @@ -39,11 +39,10 @@ import Pos.Client.Txp.Balances (getOwnUtxoForPk) import Pos.Client.Txp.Network (prepareMTx, submitTxRaw) import Pos.Client.Txp.Util (createTx) import Pos.Core as Core (Config (..), IsBootstrapEraAddr (..), - Timestamp (..), configEpochSlots, deriveFirstHDAddress, - makePubKeyAddress, mkCoin) + Timestamp (..), configBlockVersionData, configEpochSlots, + deriveFirstHDAddress, makePubKeyAddress, mkCoin) import Pos.Core.Conc (concurrently, currentTime, delay, forConcurrently, modifySharedAtomic, newSharedAtomic) -import Pos.Core.Configuration (genesisBlockVersionData) import Pos.Core.Txp (TxAux (..), TxIn (TxInUtxo), TxOut (..), TxOutAux (..), txaF) import Pos.Core.Update (BlockVersionData (..)) @@ -93,7 +92,7 @@ sendToAllGenesis -> SendToAllGenesisParams -> m () sendToAllGenesis coreConfig keysToSend diffusion (SendToAllGenesisParams genesisTxsPerThread txsPerThread conc delay_ tpsSentFile) = do - let genesisSlotDuration = fromIntegral (toMicroseconds $ bvdSlotDuration genesisBlockVersionData) `div` 1000000 :: Int + let genesisSlotDuration = fromIntegral (toMicroseconds $ bvdSlotDuration (configBlockVersionData coreConfig)) `div` 1000000 :: Int tpsMVar <- newSharedAtomic $ TxCount 0 conc startTime <- show . toInteger . getTimestamp . Timestamp <$> currentTime bracket (openFile tpsSentFile WriteMode) (liftIO . hClose) $ \h -> do diff --git a/chain/src/Pos/Chain/Update/Poll/Class.hs b/chain/src/Pos/Chain/Update/Poll/Class.hs index a57ad639599..117ce9af9eb 100644 --- a/chain/src/Pos/Chain/Update/Poll/Class.hs +++ b/chain/src/Pos/Chain/Update/Poll/Class.hs @@ -77,9 +77,9 @@ class (Monad m, WithLogger m) => MonadPollRead m where -- ^ Get active proposals for the specified application. getConfirmedProposals :: m [ConfirmedProposalState] -- ^ Get all known confirmed proposals. - getEpochTotalStake :: EpochIndex -> m (Maybe Coin) + getEpochTotalStake :: BlockVersionData -> EpochIndex -> m (Maybe Coin) -- ^ Get total stake from distribution corresponding to given epoch - getRichmanStake :: EpochIndex -> StakeholderId -> m (Maybe Coin) + getRichmanStake :: BlockVersionData -> EpochIndex -> StakeholderId -> m (Maybe Coin) -- ^ Get stake of ricmhan corresponding to given epoch (if she is -- really rich) getOldProposals :: SlotId -> m [UndecidedProposalState] @@ -115,8 +115,8 @@ instance {-# OVERLAPPABLE #-} getProposal = lift . getProposal getProposalsByApp = lift . getProposalsByApp getConfirmedProposals = lift getConfirmedProposals - getEpochTotalStake = lift . getEpochTotalStake - getRichmanStake e = lift . getRichmanStake e + getEpochTotalStake genesisBvd = lift . getEpochTotalStake genesisBvd + getRichmanStake genesisBvd e = lift . getRichmanStake genesisBvd e getOldProposals = lift . getOldProposals getDeepProposals = lift . getDeepProposals getBlockIssuerStake e = lift . getBlockIssuerStake e @@ -309,8 +309,8 @@ instance (MonadPollRead m) => MM.valuesM (map (first cpsSoftwareVersion . join (,)) <$> getConfirmedProposals) =<< use pmConfirmedPropsL - getEpochTotalStake = lift . getEpochTotalStake - getRichmanStake e = lift . getRichmanStake e + getEpochTotalStake genesisBvd = lift . getEpochTotalStake genesisBvd + getRichmanStake genesisBvd e = lift . getRichmanStake genesisBvd e getOldProposals sl = ether $ map snd <$> (MM.mapMaybeM getOldProposalPairs extractOld =<< use pmActivePropsL) diff --git a/chain/test/Test/Pos/Chain/Lrc/Arbitrary.hs b/chain/test/Test/Pos/Chain/Lrc/Arbitrary.hs index 93e45aa1db6..058b88280dc 100644 --- a/chain/test/Test/Pos/Chain/Lrc/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Lrc/Arbitrary.hs @@ -16,11 +16,10 @@ import Test.QuickCheck.Arbitrary.Generic (genericShrink) import Pos.Chain.Lrc (RichmenStakes) import Pos.Core.Common (Coin, CoinPortion, coinPortionToDouble, mkCoin, unsafeAddCoin, unsafeGetCoin, unsafeSubCoin) -import Pos.Core.Configuration (HasGenesisBlockVersionData, - genesisBlockVersionData) import Pos.Core.Update (BlockVersionData (bvdMpcThd)) import Test.Pos.Core.Arbitrary () +import Test.Pos.Core.Dummy (dummyBlockVersionData) -- | Wrapper over 'RichmenStakes'. Its 'Arbitrary' instance enforces that the -- stake distribution inside must be valid with respect to the threshold @@ -76,5 +75,5 @@ genRichmenStakes thd = do data GenesisMpcThd -instance HasGenesisBlockVersionData => Reifies GenesisMpcThd CoinPortion where - reflect _ = bvdMpcThd genesisBlockVersionData +instance Reifies GenesisMpcThd CoinPortion where + reflect _ = bvdMpcThd dummyBlockVersionData diff --git a/client/test/Test/Pos/Client/Txp/Mode.hs b/client/test/Test/Pos/Client/Txp/Mode.hs index 44448ef69dc..3a4cdf58b2d 100644 --- a/client/test/Test/Pos/Client/Txp/Mode.hs +++ b/client/test/Test/Pos/Client/Txp/Mode.hs @@ -22,12 +22,12 @@ import Pos.Chain.Update (HasUpdateConfiguration) import Pos.Client.Txp.Addresses (MonadAddresses (..)) import Pos.Configuration (HasNodeConfiguration) import Pos.Core (Address, HasConfiguration, makePubKeyAddressBoot) -import Pos.Core.Configuration (HasGenesisBlockVersionData, - genesisBlockVersionData) import Pos.Core.Update (BlockVersionData) import Pos.Crypto (deterministicKeyGen) import Pos.DB (MonadGState (..)) +import Test.Pos.Core.Dummy (dummyBlockVersionData) + ---------------------------------------------------------------------------- -- Configuration propagation ---------------------------------------------------------------------------- @@ -37,7 +37,6 @@ type HasTxpConfigurations = , HasSscConfiguration , HasConfiguration , HasUpdateConfiguration - , HasGenesisBlockVersionData ) ---------------------------------------------------------------------------- @@ -86,5 +85,5 @@ instance MonadAddresses TxpTestProperty where getNewAddress epochSlots = lift . getNewAddress epochSlots getFakeChangeAddress = lift . getFakeChangeAddress -instance (HasTxpConfigurations, Testable a) => Testable (TxpTestProperty a) where - property = monadic (ioProperty . flip runReaderT genesisBlockVersionData) +instance Testable a => Testable (TxpTestProperty a) where + property = monadic (ioProperty . flip runReaderT dummyBlockVersionData) diff --git a/core/cardano-sl-core.cabal b/core/cardano-sl-core.cabal index 11060688b2e..e8836efe566 100644 --- a/core/cardano-sl-core.cabal +++ b/core/cardano-sl-core.cabal @@ -94,7 +94,6 @@ library Pos.Core.Common.TxSizeLinear -- Configuration - Pos.Core.Configuration.BlockVersionData Pos.Core.Configuration.Core Pos.Core.Configuration.GenesisHash diff --git a/core/src/Pos/Core/Configuration.hs b/core/src/Pos/Core/Configuration.hs index e16ba0f2497..c159b8f4b1f 100644 --- a/core/src/Pos/Core/Configuration.hs +++ b/core/src/Pos/Core/Configuration.hs @@ -46,7 +46,6 @@ import qualified Text.JSON.Canonical as Canonical import Pos.Binary.Class (Raw) import Pos.Core.Common (BlockCount, SharedSeed) -import Pos.Core.Configuration.BlockVersionData as E import Pos.Core.Configuration.Core as E import Pos.Core.Configuration.GenesisHash as E import Pos.Core.Genesis (GeneratedSecrets, GenesisAvvmBalances, @@ -136,10 +135,7 @@ configFtsSeed :: Config -> SharedSeed configFtsSeed = gdFtsSeed . configGenesisData -- | Coarse catch-all configuration constraint for use by depending modules. -type HasConfiguration = - ( HasCoreConfiguration - , HasGenesisBlockVersionData - ) +type HasConfiguration = HasCoreConfiguration canonicalGenesisJson :: GenesisData -> (BSL.ByteString, Hash Raw) canonicalGenesisJson theGenesisData = (canonicalJsonBytes, jsonHash) @@ -210,7 +206,6 @@ withCoreConfigurations conf@CoreConfiguration{..} fn confDir mSystemStart mSeed (show theGenesisHash) (show expectedHash) withCoreConfiguration conf $ - withGenesisBlockVersionData (gdBlockVersionData theGenesisData) $ act $ Config { configProtocolMagic = pm @@ -252,7 +247,6 @@ withGenesisSpec withGenesisSpec theSystemStart conf@CoreConfiguration{..} fn val = case ccGenesis of GCSrc {} -> error "withGenesisSpec called with GCSrc" GCSpec spec -> - withGenesisBlockVersionData (gsBlockVersionData spec) $ let -- Generate GeneratedGenesisData {..} = @@ -272,7 +266,7 @@ withGenesisSpec theSystemStart conf@CoreConfiguration{..} fn val = case ccGenesi , gdStartTime = theSystemStart , gdVssCerts = ggdVssCerts , gdNonAvvmBalances = ggdNonAvvm - , gdBlockVersionData = genesisBlockVersionData + , gdBlockVersionData = gsBlockVersionData spec , gdProtocolConsts = gsProtocolConstants spec , gdAvvmDistr = ggdAvvm , gdFtsSeed = gsFtsSeed spec diff --git a/core/src/Pos/Core/Configuration/BlockVersionData.hs b/core/src/Pos/Core/Configuration/BlockVersionData.hs deleted file mode 100644 index 0198c16d394..00000000000 --- a/core/src/Pos/Core/Configuration/BlockVersionData.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE Rank2Types #-} - -module Pos.Core.Configuration.BlockVersionData - ( HasGenesisBlockVersionData - , withGenesisBlockVersionData - , genesisBlockVersionData - ) where - - -import Data.Reflection (Given (..), give) - -import Pos.Core.Update (BlockVersionData) - -type HasGenesisBlockVersionData = Given BlockVersionData - -withGenesisBlockVersionData :: BlockVersionData -> (HasGenesisBlockVersionData => r) -> r -withGenesisBlockVersionData = give - -genesisBlockVersionData :: HasGenesisBlockVersionData => BlockVersionData -genesisBlockVersionData = given diff --git a/core/test/Test/Pos/Core/Arbitrary.hs b/core/test/Test/Pos/Core/Arbitrary.hs index 834cf73aa1b..de3322c9956 100644 --- a/core/test/Test/Pos/Core/Arbitrary.hs +++ b/core/test/Test/Pos/Core/Arbitrary.hs @@ -52,7 +52,6 @@ import Pos.Core (AddrAttributes (..), AddrSpendingData (..), mkMultiKeyDistr, unsafeCoinPortionFromDouble, unsafeGetCoin, unsafeSubCoin) import Pos.Core.Attributes (Attributes (..), UnparsedFields (..)) -import Pos.Core.Configuration (HasGenesisBlockVersionData) import Pos.Core.Constants (sharedSeedLength) import Pos.Core.Delegation (HeavyDlgIndex (..), LightDlgIndices (..)) import qualified Pos.Core.Genesis as G @@ -511,7 +510,7 @@ instance Arbitrary TxFeePolicy where -- Arbitrary types from 'Pos.Core.Genesis' ---------------------------------------------------------------------------- -instance HasGenesisBlockVersionData => Arbitrary G.TestnetBalanceOptions where +instance Arbitrary G.TestnetBalanceOptions where arbitrary = do -- We have at least 2 owned addresses in system so we can send -- transactions in block-gen/tests. diff --git a/core/test/Test/Pos/Core/Dummy.hs b/core/test/Test/Pos/Core/Dummy.hs index 09bb5ef5077..dd082f18b6b 100644 --- a/core/test/Test/Pos/Core/Dummy.hs +++ b/core/test/Test/Pos/Core/Dummy.hs @@ -18,6 +18,7 @@ module Test.Pos.Core.Dummy , dummyGenesisSecretsPoor , dummyCoreConfiguration , dummyGenesisSpec + , dummyBlockVersionData , dummyGenesisData , dummyGenesisDataStartTime , dummyGenesisHash diff --git a/db/src/Pos/DB/Block/Logic/Creation.hs b/db/src/Pos/DB/Block/Logic/Creation.hs index 5819ae7aaf1..0d217c464dc 100644 --- a/db/src/Pos/DB/Block/Logic/Creation.hs +++ b/db/src/Pos/DB/Block/Logic/Creation.hs @@ -35,9 +35,9 @@ import Pos.Chain.Update (HasUpdateConfiguration, curSoftwareVersion, lastKnownBlockVersion) import Pos.Core as Core (BlockCount, Config (..), EpochIndex, EpochOrSlot (..), SlotId (..), configBlkSecurityParam, - configEpochSlots, epochIndexL, flattenSlotId, - getEpochOrSlot, kChainQualityThreshold, kEpochSlots, - localSlotIndexMinBound) + configBlockVersionData, configEpochSlots, epochIndexL, + flattenSlotId, getEpochOrSlot, kChainQualityThreshold, + kEpochSlots, localSlotIndexMinBound) import Pos.Core.Context (HasPrimaryKey, getOurSecretKey) import Pos.Core.Exception (assertionFailed, reportFatalError) import Pos.Core.JsonLog (CanJsonLog (..)) @@ -273,7 +273,7 @@ createMainBlockInternal coreConfig sId pske = do msgFmt = "We are trying to create main block, our tip header is\n"%build createMainBlockFinish :: BlockHeader -> ExceptT Text m MainBlock createMainBlockFinish prevHeader = do - rawPay <- lift $ getRawPayload k (headerHash prevHeader) sId + rawPay <- lift $ getRawPayload coreConfig (headerHash prevHeader) sId sk <- getOurSecretKey -- 100 bytes is substracted to account for different unexpected -- overhead. You can see that in bitcoin blocks are 1-2kB less @@ -426,14 +426,14 @@ data RawPayload = RawPayload } getRawPayload :: MonadCreateBlock ctx m - => BlockCount + => Core.Config -> HeaderHash -> SlotId -> m RawPayload -getRawPayload k tip slotId = do +getRawPayload coreConfig tip slotId = do localTxs <- txGetPayload tip -- result is topsorted - sscData <- sscGetLocalPayload k slotId - usPayload <- usPreparePayload tip slotId + sscData <- sscGetLocalPayload (configBlkSecurityParam coreConfig) slotId + usPayload <- usPreparePayload (configBlockVersionData coreConfig) tip slotId dlgPayload <- getDlgMempool let rawPayload = RawPayload diff --git a/db/src/Pos/DB/Block/Logic/Internal.hs b/db/src/Pos/DB/Block/Logic/Internal.hs index 7abd0ff4441..9adf2c9d2b9 100644 --- a/db/src/Pos/DB/Block/Logic/Internal.hs +++ b/db/src/Pos/DB/Block/Logic/Internal.hs @@ -43,7 +43,7 @@ import Pos.Chain.Ssc (HasSscConfiguration, MonadSscMem, SscBlock) import Pos.Chain.Txp (TxpConfiguration) import Pos.Chain.Update (PollModifier) import Pos.Core as Core (Config (..), configBlkSecurityParam, - configEpochSlots, epochIndexL) + configBlockVersionData, configEpochSlots, epochIndexL) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Exception (assertionFailed) import Pos.Core.Reporting (MonadReporting) @@ -133,7 +133,7 @@ normalizeMempool coreConfig txpConfig = do -- within block application. sscNormalize coreConfig txpNormalize coreConfig txpConfig - usNormalize + usNormalize (configBlockVersionData coreConfig) -- | Applies a definitely valid prefix of blocks. This function is unsafe, -- use it only if you understand what you're doing. That means you can break @@ -236,7 +236,7 @@ rollbackBlocksUnsafe coreConfig bsc scb toRollback = do -- We don't normalize other mempools, because they are normalized -- in 'applyBlocksUnsafe' and we always ensure that some blocks -- are applied after rollback. - dlgNormalizeOnRollback $ configProtocolMagic coreConfig + dlgNormalizeOnRollback coreConfig sanityCheckDB $ configGenesisData coreConfig diff --git a/db/src/Pos/DB/Block/Logic/VAR.hs b/db/src/Pos/DB/Block/Logic/VAR.hs index 989a5b2a760..01bfe95a9a7 100644 --- a/db/src/Pos/DB/Block/Logic/VAR.hs +++ b/db/src/Pos/DB/Block/Logic/VAR.hs @@ -100,8 +100,7 @@ verifyBlocksPrefix coreConfig currentSlot blocks = runExceptT $ do TxpGlobalSettings {..} <- view (lensOf @TxpGlobalSettings) txUndo <- withExceptT (VerifyBlocksError . pretty) $ ExceptT $ tgsVerifyBlocks dataMustBeKnown $ map toTxpBlock blocks - pskUndo <- withExceptT VerifyBlocksError - $ dlgVerifyBlocks (configProtocolMagic coreConfig) blocks + pskUndo <- withExceptT VerifyBlocksError $ dlgVerifyBlocks coreConfig blocks (pModifier, usUndos) <- withExceptT (VerifyBlocksError . pretty) $ ExceptT $ usVerifyBlocks coreConfig dataMustBeKnown (map toUpdateBlock blocks) diff --git a/db/src/Pos/DB/Block/Lrc.hs b/db/src/Pos/DB/Block/Lrc.hs index 40a34124a6e..97788e2f8eb 100644 --- a/db/src/Pos/DB/Block/Lrc.hs +++ b/db/src/Pos/DB/Block/Lrc.hs @@ -30,8 +30,9 @@ import Pos.Chain.Ssc (MonadSscMem, noReportNoSecretsForEpoch1) import Pos.Chain.Update (BlockVersionState (..)) import Pos.Core as Core (Coin, Config (..), EpochIndex, EpochOrSlot (..), SharedSeed, SlotCount, StakeholderId, - configBlkSecurityParam, configEpochSlots, configK, - crucialSlot, epochIndexL, getEpochOrSlot) + configBlkSecurityParam, configBlockVersionData, + configEpochSlots, configK, crucialSlot, epochIndexL, + getEpochOrSlot) import Pos.Core.Chrono (NE, NewestFirst (..), toOldestFirst) import Pos.Core.Conc (forConcurrently) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), @@ -87,7 +88,7 @@ lrcSingleShot coreConfig epoch = do %build) epoch tryAcquireExclusiveLock epoch lock onAcquiredLock where - consumers = allLrcConsumers @ctx @m + consumers = allLrcConsumers @ctx @m (configBlockVersionData coreConfig) for_thEpochMsg = sformat (" for "%ords%" epoch") epoch onAcquiredLock = do logDebug "lrcSingleShot has acquired LRC lock" @@ -153,7 +154,7 @@ lrcDo coreConfig epoch consumers = do blundsToRollback <- DB.loadBlundsFromTipWhile genesisHash whileAfterCrucial blundsToRollbackNE <- maybeThrow UnknownBlocksForLrc (atLeastKNewestFirst blundsToRollback) - seed <- sscCalculateSeed epoch >>= \case + seed <- sscCalculateSeed (configBlockVersionData coreConfig) epoch >>= \case Right s -> do logInfo $ sformat ("Calculated seed for epoch "%build%" successfully") epoch diff --git a/db/src/Pos/DB/Delegation/Logic/Mempool.hs b/db/src/Pos/DB/Delegation/Logic/Mempool.hs index a6afd70c688..90330060cf2 100644 --- a/db/src/Pos/DB/Delegation/Logic/Mempool.hs +++ b/db/src/Pos/DB/Delegation/Logic/Mempool.hs @@ -30,11 +30,12 @@ import Pos.Chain.Delegation (DlgMemPool, DlgPayload (..), MonadDelegation, cmPskMods, dwMessageCache, dwPoolSize, dwProxySKPool, dwTip, emptyCedeModifier, isRevokePsk, pskToDlgEdgeAction) -import Pos.Core (addressHash, epochIndexL) +import Pos.Core as Core (Config (..), addressHash, + configBlockVersionData, epochIndexL) import Pos.Core.Conc (currentTime) import Pos.Core.Delegation (ProxySKHeavy) import Pos.Core.Update (bvdMaxBlockSize) -import Pos.Crypto (ProtocolMagic, ProxySecretKey (..), PublicKey) +import Pos.Crypto (ProxySecretKey (..), PublicKey) import Pos.DB (MonadDBRead, MonadGState) import qualified Pos.DB as DB import Pos.DB.Delegation.Cede.Holders (evalMapCede) @@ -128,25 +129,27 @@ processProxySKHeavy , HasLens' ctx StateLock , MonadMask m ) - => ProtocolMagic -> ProxySKHeavy -> m PskHeavyVerdict -processProxySKHeavy pm psk = + => Core.Config -> ProxySKHeavy -> m PskHeavyVerdict +processProxySKHeavy coreConfig psk = withStateLockNoMetrics LowPriority $ \_stateLockHeader -> - processProxySKHeavyInternal pm psk + processProxySKHeavyInternal coreConfig psk -- | Main logic of heavy psk processing, doesn't have -- synchronization. Should be called __only__ if you are sure that -- 'StateLock' is taken already. processProxySKHeavyInternal :: forall ctx m. (ProcessHeavyConstraint ctx m) - => ProtocolMagic + => Core.Config -> ProxySKHeavy -> m PskHeavyVerdict -processProxySKHeavyInternal pm psk = do +processProxySKHeavyInternal coreConfig psk = do curTime <- microsecondsToUTC <$> currentTime dbTip <- DB.getTipHeader let dbTipHash = headerHash dbTip let headEpoch = dbTip ^. epochIndexL - richmen <- getDlgRichmen "Delegation.Logic#processProxySKHeavy" headEpoch + richmen <- getDlgRichmen (configBlockVersionData coreConfig) + "Delegation.Logic#processProxySKHeavy" + headEpoch maxBlockSize <- bvdMaxBlockSize <$> DB.gsAdoptedBVData let iPk = pskIssuerPk psk @@ -169,7 +172,11 @@ processProxySKHeavyInternal pm psk = do (const (error "processProxySKHeavyInternal:can't happen",True))) $ evalMapCede cedeModifier $ runExceptT $ - dlgVerifyPskHeavy pm richmen (CheckForCycle True) headEpoch psk + dlgVerifyPskHeavy (configProtocolMagic coreConfig) + richmen + (CheckForCycle True) + headEpoch + psk -- Here the memory state is the same. runDelegationStateAction $ do diff --git a/db/src/Pos/DB/Delegation/Logic/VAR.hs b/db/src/Pos/DB/Delegation/Logic/VAR.hs index 8f42f0fcc55..4deadb097ab 100644 --- a/db/src/Pos/DB/Delegation/Logic/VAR.hs +++ b/db/src/Pos/DB/Delegation/Logic/VAR.hs @@ -35,10 +35,11 @@ import Pos.Chain.Delegation (CedeModifier (..), DlgBlund, dwProxySKPool, dwTip, emptyCedeModifier, getPskPk, modPsk, pskToDlgEdgeAction) import Pos.Chain.Lrc (RichmenSet) -import Pos.Core (EpochIndex (..), StakeholderId, addressHash, - epochIndexL, siEpoch) +import Pos.Core as Core (Config (..), EpochIndex (..), StakeholderId, + addressHash, configBlockVersionData, epochIndexL, siEpoch) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) -import Pos.Crypto (ProtocolMagic, ProxySecretKey (..), shortHashF) +import Pos.Core.Update (BlockVersionData) +import Pos.Crypto (ProxySecretKey (..), shortHashF) import Pos.DB (DBError (DBMalformed), MonadDBRead, SomeBatchOp (..)) import qualified Pos.DB as DB import Pos.DB.Delegation.Cede.Holders (MapCede, evalMapCede, @@ -299,14 +300,15 @@ getNoLongerRichmen :: , MonadReader ctx m , HasLrcContext ctx ) - => EpochIndex + => BlockVersionData + -> EpochIndex -> m (HashSet StakeholderId) -getNoLongerRichmen (EpochIndex 0) = pure mempty -getNoLongerRichmen newEpoch = +getNoLongerRichmen _ (EpochIndex 0) = pure mempty +getNoLongerRichmen genesisBvd newEpoch = HS.difference <$> getRichmen (newEpoch - 1) <*> getRichmen newEpoch where getRichmen :: EpochIndex -> m RichmenSet - getRichmen = getDlgRichmen "getNoLongerRichmen" + getRichmen = getDlgRichmen genesisBvd "getNoLongerRichmen" -- | Verifies if blocks are correct relatively to the delegation logic -- and returns a non-empty list of proxySKs needed for undoing @@ -325,13 +327,15 @@ dlgVerifyBlocks :: , MonadReader ctx m , HasLrcContext ctx ) - => ProtocolMagic + => Core.Config -> OldestFirst NE Block -> ExceptT Text m (OldestFirst NE DlgUndo) -dlgVerifyBlocks pm blocks = do - richmen <- lift $ getDlgRichmen "dlgVerifyBlocks" headEpoch +dlgVerifyBlocks coreConfig blocks = do + richmen <- lift $ getDlgRichmen genesisBvd "dlgVerifyBlocks" headEpoch hoist (evalMapCede emptyCedeModifier) $ mapM (verifyBlock richmen) blocks where + genesisBvd = configBlockVersionData coreConfig + headEpoch = blocks ^. _Wrapped . _neHead . epochIndexL verifyBlock :: @@ -342,7 +346,7 @@ dlgVerifyBlocks pm blocks = do let blkEpoch = genesisBlk ^. epochIndexL prevThisEpochPosted <- getAllPostedThisEpoch mapM_ delThisEpochPosted prevThisEpochPosted - noLongerRichmen <- lift $ lift $ getNoLongerRichmen blkEpoch + noLongerRichmen <- lift $ lift $ getNoLongerRichmen genesisBvd blkEpoch deletedPSKs <- catMaybes <$> mapM getPsk (toList noLongerRichmen) -- We should delete all certs for people who are not richmen. let delFromCede = modPsk . DlgEdgeDel . addressHash . pskIssuerPk @@ -366,7 +370,7 @@ dlgVerifyBlocks pm blocks = do -- delete/override), apply new psks. toRollback <- fmap catMaybes $ forM proxySKs $ \psk ->do dlgVerifyPskHeavy - pm + (configProtocolMagic coreConfig) richmen (CheckForCycle False) (blk ^. mainBlockSlot . to siEpoch) @@ -504,12 +508,12 @@ dlgNormalizeOnRollback :: , DB.MonadGState m , HasLrcContext ctx ) - => ProtocolMagic -> m () -dlgNormalizeOnRollback pm = do + => Core.Config -> m () +dlgNormalizeOnRollback coreConfig = do tip <- DB.getTipHeader oldPool <- runDelegationStateAction $ do pool <- uses dwProxySKPool toList dwProxySKPool .= mempty dwTip .= headerHash tip pure pool - forM_ oldPool $ processProxySKHeavyInternal pm + forM_ oldPool $ processProxySKHeavyInternal coreConfig diff --git a/db/src/Pos/DB/Lrc/Consumer/Delegation.hs b/db/src/Pos/DB/Lrc/Consumer/Delegation.hs index 5bf15eb5f69..e4473259687 100644 --- a/db/src/Pos/DB/Lrc/Consumer/Delegation.hs +++ b/db/src/Pos/DB/Lrc/Consumer/Delegation.hs @@ -18,9 +18,8 @@ module Pos.DB.Lrc.Consumer.Delegation import Universum import Pos.Chain.Lrc (RichmenComponent (..), RichmenSet) -import Pos.Core (EpochIndex, HasGenesisBlockVersionData, - genesisBlockVersionData) -import Pos.Core.Update (bvdHeavyDelThd) +import Pos.Core (EpochIndex) +import Pos.Core.Update (BlockVersionData (..)) import Pos.DB (MonadDB, MonadDBRead, MonadGState) import Pos.DB.Lrc.Consumer (LrcConsumer, lrcConsumerFromComponentSimple) @@ -32,11 +31,11 @@ import Pos.Util.Util (getKeys) -- RichmenComponent ---------------------------------------------------------------------------- -dlgRichmenComponent :: HasGenesisBlockVersionData => RichmenComponent RichmenSet -dlgRichmenComponent = RichmenComponent +dlgRichmenComponent :: BlockVersionData -> RichmenComponent RichmenSet +dlgRichmenComponent genesisBvd = RichmenComponent { rcToData = getKeys . snd , rcTag = "dlg" - , rcInitialThreshold = bvdHeavyDelThd genesisBlockVersionData + , rcInitialThreshold = bvdHeavyDelThd genesisBvd , rcConsiderDelegated = False } @@ -45,8 +44,10 @@ dlgRichmenComponent = RichmenComponent ---------------------------------------------------------------------------- -- | Consumer will be called on every Richmen computation. -dlgLrcConsumer :: (MonadGState m, MonadDB m) => LrcConsumer m -dlgLrcConsumer = lrcConsumerFromComponentSimple dlgRichmenComponent bvdHeavyDelThd +dlgLrcConsumer :: (MonadGState m, MonadDB m) => BlockVersionData -> LrcConsumer m +dlgLrcConsumer genesisBvd = lrcConsumerFromComponentSimple + (dlgRichmenComponent genesisBvd) + bvdHeavyDelThd ---------------------------------------------------------------------------- -- Getting richmen @@ -56,14 +57,16 @@ dlgLrcConsumer = lrcConsumerFromComponentSimple dlgRichmenComponent bvdHeavyDelT -- data for the given epoch. getDlgRichmen :: (MonadIO m, MonadDBRead m, MonadReader ctx m, HasLrcContext ctx) - => Text -- ^ Function name (to include into error message) + => BlockVersionData + -> Text -- ^ Function name (to include into error message) -> EpochIndex -- ^ Epoch for which you want to know the richmen -> m RichmenSet -getDlgRichmen fname epoch = lrcActionOnEpochReason +getDlgRichmen genesisBvd fname epoch = lrcActionOnEpochReason epoch (fname <> ": couldn't get delegation richmen") - tryGetDlgRichmen + (tryGetDlgRichmen genesisBvd) -- | Like 'getDlgRichmen', but doesn't wait and doesn't fail. -tryGetDlgRichmen :: MonadDBRead m => EpochIndex -> m (Maybe RichmenSet) -tryGetDlgRichmen = getRichmen dlgRichmenComponent +tryGetDlgRichmen + :: MonadDBRead m => BlockVersionData -> EpochIndex -> m (Maybe RichmenSet) +tryGetDlgRichmen = getRichmen . dlgRichmenComponent diff --git a/db/src/Pos/DB/Lrc/Consumer/Ssc.hs b/db/src/Pos/DB/Lrc/Consumer/Ssc.hs index eb90f65646d..467a4090e1d 100644 --- a/db/src/Pos/DB/Lrc/Consumer/Ssc.hs +++ b/db/src/Pos/DB/Lrc/Consumer/Ssc.hs @@ -18,9 +18,8 @@ module Pos.DB.Lrc.Consumer.Ssc import Universum import Pos.Chain.Lrc (RichmenComponent (..), RichmenStakes) -import Pos.Core (EpochIndex, HasGenesisBlockVersionData, - genesisBlockVersionData) -import Pos.Core.Update (bvdMpcThd) +import Pos.Core (EpochIndex) +import Pos.Core.Update (BlockVersionData (..)) import Pos.DB (MonadDB, MonadDBRead, MonadGState) import Pos.DB.Lrc.Consumer (LrcConsumer, lrcConsumerFromComponentSimple) @@ -31,11 +30,11 @@ import Pos.DB.Lrc.RichmenBase (getRichmen) -- RichmenComponent ---------------------------------------------------------------------------- -sscRichmenComponent :: HasGenesisBlockVersionData => RichmenComponent RichmenStakes -sscRichmenComponent = RichmenComponent +sscRichmenComponent :: BlockVersionData -> RichmenComponent RichmenStakes +sscRichmenComponent genesisBvd = RichmenComponent { rcToData = snd , rcTag = "ssc" - , rcInitialThreshold = bvdMpcThd genesisBlockVersionData + , rcInitialThreshold = bvdMpcThd genesisBvd , rcConsiderDelegated = True } @@ -44,8 +43,9 @@ sscRichmenComponent = RichmenComponent ---------------------------------------------------------------------------- -- | Consumer will be called on every Richmen computation. -sscLrcConsumer :: (MonadGState m, MonadDB m) => LrcConsumer m -sscLrcConsumer = lrcConsumerFromComponentSimple sscRichmenComponent bvdMpcThd +sscLrcConsumer :: (MonadGState m, MonadDB m) => BlockVersionData -> LrcConsumer m +sscLrcConsumer genesisBvd = + lrcConsumerFromComponentSimple (sscRichmenComponent genesisBvd) bvdMpcThd ---------------------------------------------------------------------------- -- Getting richmen @@ -55,14 +55,19 @@ sscLrcConsumer = lrcConsumerFromComponentSimple sscRichmenComponent bvdMpcThd -- ricmen for the given epoch. getSscRichmen :: (MonadIO m, MonadDBRead m, MonadReader ctx m, HasLrcContext ctx) - => Text -- ^ Function name (to include into error message) + => BlockVersionData + -> Text -- ^ Function name (to include into error message) -> EpochIndex -- ^ Epoch for which you want to know the richmen -> m RichmenStakes -getSscRichmen fname epoch = lrcActionOnEpochReason +getSscRichmen genesisBvd fname epoch = lrcActionOnEpochReason epoch (fname <> ": couldn't get SSC richmen") - tryGetSscRichmen + (tryGetSscRichmen genesisBvd) -- | Like 'getSscRichmen', but doesn't wait and doesn't fail. -tryGetSscRichmen :: MonadDBRead m => EpochIndex -> m (Maybe RichmenStakes) -tryGetSscRichmen = getRichmen sscRichmenComponent +tryGetSscRichmen + :: MonadDBRead m + => BlockVersionData + -> EpochIndex + -> m (Maybe RichmenStakes) +tryGetSscRichmen = getRichmen . sscRichmenComponent diff --git a/db/src/Pos/DB/Lrc/Consumer/Update.hs b/db/src/Pos/DB/Lrc/Consumer/Update.hs index 2cb36b2425b..5da8763d161 100644 --- a/db/src/Pos/DB/Lrc/Consumer/Update.hs +++ b/db/src/Pos/DB/Lrc/Consumer/Update.hs @@ -18,9 +18,8 @@ module Pos.DB.Lrc.Consumer.Update import Universum import Pos.Chain.Lrc (FullRichmenData, RichmenComponent (..)) -import Pos.Core (EpochIndex, HasGenesisBlockVersionData, - genesisBlockVersionData) -import Pos.Core.Update (bvdUpdateVoteThd) +import Pos.Core (EpochIndex) +import Pos.Core.Update (BlockVersionData (..)) import Pos.DB (MonadDB, MonadDBRead, MonadGState) import Pos.DB.Lrc.Consumer (LrcConsumer, lrcConsumerFromComponentSimple) @@ -31,11 +30,11 @@ import Pos.DB.Lrc.RichmenBase -- RichmenComponent ---------------------------------------------------------------------------- -updateRichmenComponent :: HasGenesisBlockVersionData => RichmenComponent FullRichmenData -updateRichmenComponent = RichmenComponent +updateRichmenComponent :: BlockVersionData -> RichmenComponent FullRichmenData +updateRichmenComponent genesisBvd = RichmenComponent { rcToData = identity , rcTag = "us" - , rcInitialThreshold = bvdUpdateVoteThd genesisBlockVersionData + , rcInitialThreshold = bvdUpdateVoteThd genesisBvd , rcConsiderDelegated = True } @@ -44,8 +43,10 @@ updateRichmenComponent = RichmenComponent ---------------------------------------------------------------------------- -- | Consumer will be called on every Richmen computation. -usLrcConsumer :: (MonadGState m, MonadDB m) => LrcConsumer m -usLrcConsumer = lrcConsumerFromComponentSimple updateRichmenComponent bvdUpdateVoteThd +usLrcConsumer :: (MonadGState m, MonadDB m) => BlockVersionData -> LrcConsumer m +usLrcConsumer genesisBvd = lrcConsumerFromComponentSimple + (updateRichmenComponent genesisBvd) + bvdUpdateVoteThd ---------------------------------------------------------------------------- -- Getting richmen @@ -55,16 +56,21 @@ usLrcConsumer = lrcConsumerFromComponentSimple updateRichmenComponent bvdUpdateV -- ricmen data for the given epoch. getUSRichmen :: (MonadIO m, MonadDBRead m, MonadReader ctx m, HasLrcContext ctx) - => Text -- ^ Function name (to include into error message) + => BlockVersionData + -> Text -- ^ Function name (to include into error message) -> EpochIndex -- ^ Epoch for which you want to know the richmen -> m FullRichmenData -getUSRichmen fname epoch = lrcActionOnEpochReason +getUSRichmen genesisBvd fname epoch = lrcActionOnEpochReason epoch (fname <> ": couldn't get US richmen") - tryGetUSRichmen + (tryGetUSRichmen genesisBvd) -- | Like 'getUSRichmen', but doesn't wait and doesn't fail. -- -- Returns a 'Maybe'. -tryGetUSRichmen :: MonadDBRead m => EpochIndex -> m (Maybe FullRichmenData) -tryGetUSRichmen = getRichmen updateRichmenComponent +tryGetUSRichmen + :: MonadDBRead m + => BlockVersionData + -> EpochIndex + -> m (Maybe FullRichmenData) +tryGetUSRichmen = getRichmen . updateRichmenComponent diff --git a/db/src/Pos/DB/Lrc/Consumers.hs b/db/src/Pos/DB/Lrc/Consumers.hs index 3409f6239c1..aaf796a11fc 100644 --- a/db/src/Pos/DB/Lrc/Consumers.hs +++ b/db/src/Pos/DB/Lrc/Consumers.hs @@ -5,11 +5,15 @@ module Pos.DB.Lrc.Consumers ( allLrcConsumers ) where +import Universum + +import Pos.Core.Update (BlockVersionData) import Pos.DB.Lrc.Consumer (LrcConsumer) import Pos.DB.Lrc.Consumer.Delegation (dlgLrcConsumer) import Pos.DB.Lrc.Consumer.Ssc (sscLrcConsumer) import Pos.DB.Lrc.Consumer.Update (usLrcConsumer) import Pos.DB.Lrc.Mode (LrcMode) -allLrcConsumers :: LrcMode ctx m => [LrcConsumer m] -allLrcConsumers = [dlgLrcConsumer, usLrcConsumer, sscLrcConsumer] +allLrcConsumers :: LrcMode ctx m => BlockVersionData -> [LrcConsumer m] +allLrcConsumers genesisBvd = + ($ genesisBvd) <$> [dlgLrcConsumer, usLrcConsumer, sscLrcConsumer] diff --git a/db/src/Pos/DB/Lrc/Lrc.hs b/db/src/Pos/DB/Lrc/Lrc.hs index 651f58a36fd..3e90e22f2e4 100644 --- a/db/src/Pos/DB/Lrc/Lrc.hs +++ b/db/src/Pos/DB/Lrc/Lrc.hs @@ -6,7 +6,8 @@ module Pos.DB.Lrc.Lrc import Universum -import Pos.Core as Core (Config (..), configFtsSeed) +import Pos.Core as Core (Config (..), configBlockVersionData, + configFtsSeed) import Pos.DB.Class (MonadDB) import Pos.DB.Error (DBError (..)) import Pos.DB.Lrc.Common (prepareLrcCommon) @@ -21,10 +22,14 @@ import Pos.Util (maybeThrow) prepareLrcDB :: MonadDB m => Core.Config -> m () prepareLrcDB coreConfig = do prepareLrcLeaders coreConfig - prepareLrcRichmen (configGenesisData coreConfig) + prepareLrcRichmen coreConfig let cantReadErr = DBMalformed "Can't read richmen US after richmen initialization" - totalStake <- fst <$> (maybeThrow cantReadErr =<< tryGetUSRichmen 0) + totalStake <- + fst + <$> ( maybeThrow cantReadErr + =<< tryGetUSRichmen (configBlockVersionData coreConfig) 0 + ) prepareLrcIssuers totalStake prepareLrcSeed (configFtsSeed coreConfig) prepareLrcCommon diff --git a/db/src/Pos/DB/Lrc/Richmen.hs b/db/src/Pos/DB/Lrc/Richmen.hs index 8fe2e7005fb..cfda82d181e 100644 --- a/db/src/Pos/DB/Lrc/Richmen.hs +++ b/db/src/Pos/DB/Lrc/Richmen.hs @@ -30,8 +30,9 @@ import Pos.Binary.Class (Bi) import Pos.Chain.Lrc (FullRichmenData, RichmenComponent (..), findDelegationStakes, findRichmenStakes) import Pos.Chain.Txp (genesisStakes) -import Pos.Core (Coin, CoinPortion, StakeholderId, addressHash, - applyCoinPortionUp, sumCoins, unsafeIntegerToCoin) +import Pos.Core as Core (Coin, CoinPortion, Config (..), + StakeholderId, addressHash, applyCoinPortionUp, + configBlockVersionData, sumCoins, unsafeIntegerToCoin) import Pos.Core.Delegation (ProxySKHeavy) import Pos.Core.Genesis (GenesisData, gdHeavyDelegation, unGenesisDelegation) @@ -48,11 +49,14 @@ import Pos.DB.Lrc.RichmenBase (getRichmen, putRichmen) -- Initialization ---------------------------------------------------------------------------- -prepareLrcRichmen :: MonadDB m => GenesisData -> m () -prepareLrcRichmen genesisData = do - prepareLrcRichmenDo genesisData sscRichmenComponent - prepareLrcRichmenDo genesisData updateRichmenComponent - prepareLrcRichmenDo genesisData dlgRichmenComponent +prepareLrcRichmen :: MonadDB m => Core.Config -> m () +prepareLrcRichmen coreConfig = do + prepareLrcRichmenDo genesisData (sscRichmenComponent genesisBvd) + prepareLrcRichmenDo genesisData (updateRichmenComponent genesisBvd) + prepareLrcRichmenDo genesisData (dlgRichmenComponent genesisBvd) + where + genesisData = configGenesisData coreConfig + genesisBvd = configBlockVersionData coreConfig prepareLrcRichmenDo :: (Bi richmenData, MonadDB m) diff --git a/db/src/Pos/DB/Ssc/Logic/Global.hs b/db/src/Pos/DB/Ssc/Logic/Global.hs index e6718b4c301..d0697360823 100644 --- a/db/src/Pos/DB/Ssc/Logic/Global.hs +++ b/db/src/Pos/DB/Ssc/Logic/Global.hs @@ -17,6 +17,7 @@ import Pos.Chain.Ssc (MonadSscMem, SscGlobalQuery, SscSeedError, import qualified Pos.Chain.Ssc as Ssc import Pos.Core (EpochIndex (..), SharedSeed) import Pos.Core.Ssc (VssCertificatesMap (..), vcVssKey) +import Pos.Core.Update (BlockVersionData) import Pos.DB (MonadDBRead) import Pos.DB.Lrc (HasLrcContext, getSscRichmen) @@ -32,14 +33,15 @@ sscCalculateSeed , HasLrcContext ctx , MonadIO m ) - => EpochIndex + => BlockVersionData + -> EpochIndex -> m (Either SscSeedError SharedSeed) -sscCalculateSeed epoch = do +sscCalculateSeed genesisBvd epoch = do -- We take richmen for the previous epoch because during N-th epoch we -- were using richmen for N-th epoch for everything – so, when we are -- calculating the seed for N+1-th epoch, we should still use data from -- N-th epoch. - richmen <- getSscRichmen "sscCalculateSeed" (epoch - 1) + richmen <- getSscRichmen genesisBvd "sscCalculateSeed" (epoch - 1) sscRunGlobalQuery $ sscCalculateSeedQ richmen sscCalculateSeedQ diff --git a/db/src/Pos/DB/Ssc/Logic/Local.hs b/db/src/Pos/DB/Ssc/Logic/Local.hs index 6055a220cbc..b4a09a60526 100644 --- a/db/src/Pos/DB/Ssc/Logic/Local.hs +++ b/db/src/Pos/DB/Ssc/Logic/Local.hs @@ -42,8 +42,9 @@ import Pos.Chain.Ssc (HasSscConfiguration, MonadSscMem, PureToss, tmCommitments, tmOpenings, tmShares, verifyAndApplySscPayload) import Pos.Core as Core (BlockCount, Config, EpochIndex, SlotId (..), - StakeholderId, configBlkSecurityParam, configEpochSlots, - epochIndexL, kEpochSlots) + StakeholderId, configBlkSecurityParam, + configBlockVersionData, configEpochSlots, epochIndexL, + kEpochSlots) import Pos.Core.Slotting (MonadSlots (getCurrentSlot)) import Pos.Core.Ssc (InnerSharesMap, Opening, SignedCommitment, SscPayload (..), VssCertificate, mkCommitmentsMap, @@ -103,7 +104,9 @@ sscNormalize -> m () sscNormalize coreConfig = do tipEpoch <- view epochIndexL <$> getTipHeader - richmenData <- getSscRichmen "sscNormalize" tipEpoch + richmenData <- getSscRichmen (configBlockVersionData coreConfig) + "sscNormalize" + tipEpoch bvd <- gsAdoptedBVData globalVar <- sscGlobal <$> askSscMem localVar <- sscLocal <$> askSscMem @@ -241,7 +244,7 @@ sscProcessData coreConfig tag payload = bvd <- gsAdoptedBVData let epoch = ld ^. ldEpoch seed <- Rand.drgNew - lift (tryGetSscRichmen epoch) >>= \case + lift (tryGetSscRichmen (configBlockVersionData coreConfig) epoch) >>= \case Nothing -> throwError $ TossUnknownRichmen epoch Just richmen -> do gs <- sscRunGlobalQuery ask diff --git a/db/src/Pos/DB/Ssc/Logic/VAR.hs b/db/src/Pos/DB/Ssc/Logic/VAR.hs index ebae2f84909..0dfc3f5a79a 100644 --- a/db/src/Pos/DB/Ssc/Logic/VAR.hs +++ b/db/src/Pos/DB/Ssc/Logic/VAR.hs @@ -29,7 +29,7 @@ import Pos.Chain.Ssc (HasSscConfiguration, MonadSscMem, sscIsCriticalVerifyError, sscRunGlobalUpdate, supplyPureTossEnv, verifyAndApplySscPayload) import Pos.Core as Core (Config, HasCoreConfiguration, SlotCount, - epochIndexL, epochOrSlotG) + configBlockVersionData, epochIndexL, epochOrSlotG) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Exception (assertionFailed) import Pos.Core.Reporting (MonadReporting, reportError) @@ -88,7 +88,9 @@ sscVerifyBlocks coreConfig blocks = do lastEpoch inAssertMode $ unless (epoch == lastEpoch) $ assertionFailed differentEpochsMsg - richmenSet <- getSscRichmen "sscVerifyBlocks" epoch + richmenSet <- getSscRichmen (configBlockVersionData coreConfig) + "sscVerifyBlocks" + epoch bvd <- gsAdoptedBVData globalVar <- sscGlobal <$> askSscMem gs <- readTVarIO globalVar diff --git a/db/src/Pos/DB/Update/GState.hs b/db/src/Pos/DB/Update/GState.hs index 9bc828a974e..24d86a72e5c 100644 --- a/db/src/Pos/DB/Update/GState.hs +++ b/db/src/Pos/DB/Update/GState.hs @@ -58,10 +58,9 @@ import Pos.Chain.Update (BlockVersionState (..), cpsSoftwareVersion, genesisBlockVersion, genesisSoftwareVersions, ourAppName, ourSystemTag, psProposal) -import Pos.Core (ChainDifficulty, HasCoreConfiguration, - ProtocolConstants, SlotId, StakeholderId, TimeDiff (..), - pcEpochSlots) -import Pos.Core.Configuration (genesisBlockVersionData) +import Pos.Core as Core (ChainDifficulty, Config (..), + HasCoreConfiguration, SlotId, StakeholderId, + TimeDiff (..), configBlockVersionData, configEpochSlots) import Pos.Core.Slotting (EpochSlottingData (..), SlottingData, createInitSlottingData) import Pos.Core.Update (ApplicationName, BlockVersion, @@ -171,18 +170,19 @@ instance HasCoreConfiguration => RocksBatchOp UpdateOp where -- Initialization ---------------------------------------------------------------------------- -initGStateUS :: MonadDB m => ProtocolConstants -> m () -initGStateUS pc = do +initGStateUS :: MonadDB m => Core.Config -> m () +initGStateUS coreConfig = do writeBatchGState $ PutSlottingData genesisSlottingData : PutEpochProposers mempty : - SetAdopted genesisBlockVersion genesisBlockVersionData : + SetAdopted genesisBlockVersion genesisBvd : map ConfirmVersion genesisSoftwareVersions where - genesisSlotDuration = bvdSlotDuration genesisBlockVersionData + genesisBvd = configBlockVersionData coreConfig + genesisSlotDuration = bvdSlotDuration genesisBvd genesisEpochDuration :: Microsecond - genesisEpochDuration = fromIntegral (pcEpochSlots pc) * convertUnit genesisSlotDuration + genesisEpochDuration = fromIntegral (configEpochSlots coreConfig) * convertUnit genesisSlotDuration esdCurrent :: EpochSlottingData esdCurrent = EpochSlottingData diff --git a/db/src/Pos/DB/Update/Logic/Global.hs b/db/src/Pos/DB/Update/Logic/Global.hs index 8be7a43c613..c5ef698273e 100644 --- a/db/src/Pos/DB/Update/Logic/Global.hs +++ b/db/src/Pos/DB/Update/Logic/Global.hs @@ -25,8 +25,7 @@ import Pos.Chain.Update (BlockVersionState, ConfirmedProposalState, execRollT, getAdoptedBV, lastKnownBlockVersion, reportUnexpectedError, runPollT) import Pos.Core as Core (Config, HasCoreConfiguration, StakeholderId, - addressHash, configBlkSecurityParam, configEpochSlots, - epochIndexL) + addressHash, configBlkSecurityParam, epochIndexL) import Pos.Core.Chrono (NE, NewestFirst, OldestFirst) import Pos.Core.Exception (reportFatalError) import Pos.Core.Reporting (MonadReporting) @@ -194,8 +193,7 @@ verifyBlock -> UpdateBlock -> m USUndo verifyBlock coreConfig _ _ (ComponentBlockGenesis genBlk) = - execRollT $ processGenesisBlock (configEpochSlots coreConfig) - (genBlk ^. epochIndexL) + execRollT $ processGenesisBlock coreConfig (genBlk ^. epochIndexL) verifyBlock coreConfig lastAdopted verifyAllIsKnown (ComponentBlockMain header payload) = execRollT $ do verifyAndApplyUSPayload diff --git a/db/src/Pos/DB/Update/Logic/Local.hs b/db/src/Pos/DB/Update/Logic/Local.hs index 54058d4d5ee..0b48ddd6894 100644 --- a/db/src/Pos/DB/Update/Logic/Local.hs +++ b/db/src/Pos/DB/Update/Logic/Local.hs @@ -41,7 +41,8 @@ import Pos.Chain.Update (HasUpdateConfiguration, PollVerFailure (..), canCombineVotes, evalPollT, execPollT, getAdoptedBV, modifyPollModifier, psVotes, reportUnexpectedError, runPollT) -import Pos.Core as Core (Config, SlotId (..), slotIdF) +import Pos.Core as Core (Config, SlotId (..), configBlockVersionData, + slotIdF) import Pos.Core.Reporting (MonadReporting) import Pos.Core.Update (BlockVersionData (..), UpId, UpdatePayload (..), UpdateProposal, UpdateVote (..)) @@ -150,7 +151,8 @@ processSkeleton coreConfig payload = maxBlockSize <- bvdMaxBlockSize <$> lift DB.getAdoptedBVData msIntermediate <- -- TODO: This is a rather arbitrary limit, we should revisit it (see CSL-1664) - if | maxBlockSize * 2 <= mpSize msPool -> lift (refreshMemPool ms) + if | maxBlockSize * 2 <= mpSize msPool -> + lift (refreshMemPool (configBlockVersionData coreConfig) ms) | otherwise -> pure ms processSkeletonDo msIntermediate where @@ -175,11 +177,11 @@ refreshMemPool , WithLogger m , HasUpdateConfiguration ) - => MemState -> m MemState -refreshMemPool ms@MemState {..} = do + => BlockVersionData -> MemState -> m MemState +refreshMemPool genesisBvd ms@MemState {..} = do let MemPool {..} = msPool - ((newProposals, newVotes), newModifier) <- - runDBPoll . runPollT def $ refreshPoll msSlot mpProposals mpLocalVotes + ((newProposals, newVotes), newModifier) <- runDBPoll . runPollT def + $ refreshPoll genesisBvd msSlot mpProposals mpLocalVotes let newPool = MemPool { mpProposals = newProposals @@ -285,11 +287,11 @@ processVote coreConfig vote = -- current GState. This function assumes that GState is locked. It -- tries to leave as much data as possible. It assumes that -- 'stateLock' is taken. -usNormalize :: USLocalLogicMode ctx m => m () -usNormalize = do +usNormalize :: USLocalLogicMode ctx m => BlockVersionData -> m () +usNormalize genesisBvd = do tip <- DB.getTip stateVar <- mvState <$> views (lensOf @UpdateContext) ucMemState - atomically . writeTVar stateVar =<< usNormalizeDo (Just tip) Nothing + atomically . writeTVar stateVar =<< usNormalizeDo genesisBvd (Just tip) Nothing -- Normalization under lock. Note that here we don't care whether tip -- in mempool is the same as the one is DB, because we take payload @@ -297,13 +299,13 @@ usNormalize = do -- GState. usNormalizeDo :: USLocalLogicMode ctx m - => Maybe HeaderHash -> Maybe SlotId -> m MemState -usNormalizeDo tip slot = do + => BlockVersionData -> Maybe HeaderHash -> Maybe SlotId -> m MemState +usNormalizeDo genesisBvd tip slot = do stateVar <- mvState <$> views (lensOf @UpdateContext) ucMemState ms@MemState {..} <- readTVarIO stateVar let MemPool {..} = msPool - ((newProposals, newVotes), newModifier) <- - runDBPoll . runPollT def $ normalizePoll msSlot mpProposals mpLocalVotes + ((newProposals, newVotes), newModifier) <- runDBPoll . runPollT def + $ normalizePoll genesisBvd msSlot mpProposals mpLocalVotes let newTip = fromMaybe msTip tip let newSlot = fromMaybe msSlot slot let newPool = @@ -322,15 +324,17 @@ usNormalizeDo tip slot = do return newMS -- | Update memory state to make it correct for given slot. -processNewSlot :: USLocalLogicModeWithLock ctx m => SlotId -> m () -processNewSlot slotId = withUSLock $ processNewSlotNoLock slotId +processNewSlot + :: USLocalLogicModeWithLock ctx m => BlockVersionData -> SlotId -> m () +processNewSlot genesisBvd slotId = + withUSLock $ processNewSlotNoLock genesisBvd slotId -processNewSlotNoLock :: USLocalLogicMode ctx m => SlotId -> m () -processNewSlotNoLock slotId = modifyMemState $ \ms@MemState{..} -> do +processNewSlotNoLock :: USLocalLogicMode ctx m => BlockVersionData -> SlotId -> m () +processNewSlotNoLock genesisBvd slotId = modifyMemState $ \ms@MemState{..} -> do if | msSlot >= slotId -> pure ms -- Crucial changes happen only when epoch changes. | siEpoch msSlot == siEpoch slotId -> pure $ ms {msSlot = slotId} - | otherwise -> usNormalizeDo Nothing (Just slotId) + | otherwise -> usNormalizeDo genesisBvd Nothing (Just slotId) -- | Prepare UpdatePayload for inclusion into new block with given -- SlotId based on given tip. This function assumes that @@ -345,16 +349,17 @@ processNewSlotNoLock slotId = modifyMemState $ \ms@MemState{..} -> do -- maintenance (empty blocks are better than no blocks). usPreparePayload :: USLocalLogicMode ctx m - => HeaderHash + => BlockVersionData + -> HeaderHash -> SlotId -> m UpdatePayload -usPreparePayload neededTip slotId@SlotId{..} = do +usPreparePayload genesisBvd neededTip slotId@SlotId{..} = do -- First of all, we make sure that mem state corresponds to given -- slot. If mem state corresponds to newer slot already, it won't -- be updated, but we don't want to create block in this case -- anyway. In normal cases 'processNewSlot' can't fail here -- because of tip mismatch, because we are under 'stateLock'. - processNewSlotNoLock slotId + processNewSlotNoLock genesisBvd slotId -- After that we normalize payload to be sure it's valid. We try -- to keep it valid anyway, but we decided to have an extra -- precaution. We also do it because here we need to eliminate all @@ -365,7 +370,7 @@ usPreparePayload neededTip slotId@SlotId{..} = do where preparePayloadDo = do -- Normalization is done just in case, as said before - MemState {..} <- usNormalizeDo Nothing (Just slotId) + MemState {..} <- usNormalizeDo genesisBvd Nothing (Just slotId) -- If slot doesn't match, we can't provide payload for this slot. if | msSlot /= slotId -> def <$ logWarning (sformat slotMismatchFmt msSlot slotId) @@ -376,7 +381,7 @@ usPreparePayload neededTip slotId@SlotId{..} = do -- positive stake for inclusion into payload. let MemPool {..} = msPool (filteredProposals, bad) <- runDBPoll . evalPollT msModifier $ - filterProposalsByThd siEpoch mpProposals + filterProposalsByThd genesisBvd siEpoch mpProposals runDBPoll . evalPollT msModifier $ finishPrepare bad filteredProposals mpLocalVotes slotMismatchFmt = "US payload can't be created due to slot mismatch "% diff --git a/db/src/Pos/DB/Update/Poll/DBPoll.hs b/db/src/Pos/DB/Update/Poll/DBPoll.hs index 1facfe82586..76229630583 100644 --- a/db/src/Pos/DB/Update/Poll/DBPoll.hs +++ b/db/src/Pos/DB/Update/Poll/DBPoll.hs @@ -17,7 +17,7 @@ import UnliftIO (MonadUnliftIO) import Pos.Chain.Lrc (FullRichmenData) import Pos.Chain.Update (HasUpdateConfiguration, MonadPollRead (..)) -import Pos.Core (Coin, HasGenesisBlockVersionData) +import Pos.Core (Coin) import Pos.DB.Class (MonadDBRead) import Pos.DB.Lrc (HasLrcContext, getIssuersStakes, lrcActionOnEpochReason, tryGetUSRichmen) @@ -42,7 +42,6 @@ instance ( MonadIO m , MonadReader ctx m , HasLrcContext ctx , HasUpdateConfiguration - , HasGenesisBlockVersionData ) => MonadPollRead (DBPoll m) where getBVState = GS.getBVState @@ -54,8 +53,9 @@ instance ( MonadIO m getProposal = GS.getProposalState getProposalsByApp = GS.getProposalsByApp getConfirmedProposals = GS.getConfirmedProposals Nothing - getEpochTotalStake e = fmap fst <$> tryGetUSRichmen e - getRichmanStake e id = (findStake =<<) <$> tryGetUSRichmen e + getEpochTotalStake genesisBvd e = fmap fst <$> tryGetUSRichmen genesisBvd e + getRichmanStake genesisBvd e id = + (findStake =<<) <$> tryGetUSRichmen genesisBvd e where findStake :: FullRichmenData -> Maybe Coin findStake = HM.lookup id . snd diff --git a/db/src/Pos/DB/Update/Poll/Logic/Apply.hs b/db/src/Pos/DB/Update/Poll/Logic/Apply.hs index 5ccac556678..3638ff6521f 100644 --- a/db/src/Pos/DB/Update/Poll/Logic/Apply.hs +++ b/db/src/Pos/DB/Update/Poll/Logic/Apply.hs @@ -27,9 +27,9 @@ import Pos.Chain.Update (ConfirmedProposalState (..), import Pos.Core as Core (BlockCount, ChainDifficulty (..), Coin, Config (..), EpochIndex, SlotCount, SlotId (..), addressHash, applyCoinPortionUp, coinToInteger, - configBlkSecurityParam, configEpochSlots, difficultyL, - epochIndexL, flattenSlotId, sumCoins, unflattenSlotId, - unsafeIntegerToCoin) + configBlkSecurityParam, configBlockVersionData, + configEpochSlots, difficultyL, epochIndexL, flattenSlotId, + sumCoins, unflattenSlotId, unsafeIntegerToCoin) import Pos.Core.Attributes (areAttributesKnown) import Pos.Core.Update (BlockVersion, BlockVersionData (..), SoftwareVersion (..), UpId, UpdatePayload (..), @@ -87,15 +87,18 @@ verifyAndApplyUSPayload coreConfig lastAdopted verifyAllIsKnown slotOrHeader upp let (curPropVotes, otherVotes) = partition votePredicate upVotes let otherGroups = NE.groupWith uvProposalId otherVotes -- When there is proposal in payload, it's verified and applied. - whenJust upProposal $ - verifyAndApplyProposal verifyAllIsKnown slotOrHeader curPropVotes + whenJust upProposal $ verifyAndApplyProposal + genesisBvd + verifyAllIsKnown + slotOrHeader + curPropVotes -- Then we also apply votes from other groups. -- ChainDifficulty is needed, because proposal may become approved -- and then we'll need to track whether it becomes confirmed. let cd = case slotOrHeader of Left _ -> Nothing Right h -> Just (h ^. difficultyL, h ^. headerHashG) - mapM_ (verifyAndApplyVotesGroup cd) otherGroups + mapM_ (verifyAndApplyVotesGroup genesisBvd cd) otherGroups -- If we are applying payload from block, we also check implicit -- agreement rule and depth of decided proposals (they can become -- confirmed/discarded). @@ -113,6 +116,7 @@ verifyAndApplyUSPayload coreConfig lastAdopted verifyAllIsKnown slotOrHeader upp (mainHeader ^. headerHashG) (mainHeader ^. difficultyL) where + genesisBvd = configBlockVersionData coreConfig isEmptyPayload = isNothing upProposal && null upVotes -- Here we verify all US-related data from header. @@ -129,13 +133,13 @@ verifyHeader lastAdopted header = do -- If stakeholder wasn't richman at that point, PollNotRichman is thrown. resolveVoteStake :: (MonadError PollVerFailure m, MonadPollRead m) - => EpochIndex -> Coin -> UpdateVote -> m Coin -resolveVoteStake epoch totalStake vote = do + => BlockVersionData -> EpochIndex -> Coin -> UpdateVote -> m Coin +resolveVoteStake genesisBvd epoch totalStake vote = do let !id = addressHash (uvKey vote) thresholdPortion <- bvdUpdateProposalThd <$> getAdoptedBVData let threshold = applyCoinPortionUp thresholdPortion totalStake let errNotRichman mbStake = PollNotRichman id threshold mbStake - stake <- note (errNotRichman Nothing) =<< getRichmanStake epoch id + stake <- note (errNotRichman Nothing) =<< getRichmanStake genesisBvd epoch id when (stake < threshold) $ throwError $ errNotRichman (Just stake) return stake @@ -159,12 +163,13 @@ resolveVoteStake epoch totalStake vote = do -- state (if it has enough voted stake at once). verifyAndApplyProposal :: (MonadError PollVerFailure m, MonadPoll m) - => Bool + => BlockVersionData + -> Bool -> Either SlotId (Some IsMainHeader) -> [UpdateVote] -> UpdateProposal -> m () -verifyAndApplyProposal verifyAllIsKnown slotOrHeader votes +verifyAndApplyProposal genesisBvd verifyAllIsKnown slotOrHeader votes up@UnsafeUpdateProposal {..} = do let !upId = hash up let !upFromId = addressHash upFrom @@ -190,9 +195,11 @@ verifyAndApplyProposal verifyAllIsKnown slotOrHeader votes -- We also verify that software version is expected one. verifySoftwareVersion upId up -- After that we resolve stakes of all votes. - totalStake <- note (PollUnknownStakes epoch) =<< getEpochTotalStake epoch - votesAndStakes <- - mapM (\v -> (v, ) <$> resolveVoteStake epoch totalStake v) votes + totalStake <- note (PollUnknownStakes epoch) + =<< getEpochTotalStake genesisBvd epoch + votesAndStakes <- mapM + (\v -> (v, ) <$> resolveVoteStake genesisBvd epoch totalStake v) + votes -- When necessary, we also check that proposal itself has enough -- positive votes to be included into block. when (isRight slotOrHeader) $ @@ -231,8 +238,11 @@ verifyProposalStake totalStake votesAndStakes upId = do -- Votes are assumed to be for the same proposal. verifyAndApplyVotesGroup :: ApplyMode m - => Maybe (ChainDifficulty, HeaderHash) -> NonEmpty UpdateVote -> m () -verifyAndApplyVotesGroup cd votes = mapM_ verifyAndApplyVote votes + => BlockVersionData + -> Maybe (ChainDifficulty, HeaderHash) + -> NonEmpty UpdateVote + -> m () +verifyAndApplyVotesGroup genesisBvd cd votes = mapM_ verifyAndApplyVote votes where upId = uvProposalId $ NE.head votes verifyAndApplyVote vote = do @@ -242,19 +252,20 @@ verifyAndApplyVotesGroup cd votes = mapM_ verifyAndApplyVote votes case ps of PSDecided _ -> throwError $ PollProposalIsDecided upId stakeholderId - PSUndecided ups -> verifyAndApplyVoteDo cd ups vote + PSUndecided ups -> verifyAndApplyVoteDo genesisBvd cd ups vote -- Here we actually apply vote to stored undecided proposal. verifyAndApplyVoteDo :: ApplyMode m - => Maybe (ChainDifficulty, HeaderHash) + => BlockVersionData + -> Maybe (ChainDifficulty, HeaderHash) -> UndecidedProposalState -> UpdateVote -> m () -verifyAndApplyVoteDo cd ups vote = do +verifyAndApplyVoteDo genesisBvd cd ups vote = do let e = siEpoch $ upsSlot ups - totalStake <- note (PollUnknownStakes e) =<< getEpochTotalStake e - voteStake <- resolveVoteStake e totalStake vote + totalStake <- note (PollUnknownStakes e) =<< getEpochTotalStake genesisBvd e + voteStake <- resolveVoteStake genesisBvd e totalStake vote newUPS@UndecidedProposalState {..} <- voteToUProposalState (uvKey vote) voteStake (uvDecision vote) ups let newPS diff --git a/db/src/Pos/DB/Update/Poll/Logic/Normalize.hs b/db/src/Pos/DB/Update/Poll/Logic/Normalize.hs index 1c64cf8f407..f261d763919 100644 --- a/db/src/Pos/DB/Update/Poll/Logic/Normalize.hs +++ b/db/src/Pos/DB/Update/Poll/Logic/Normalize.hs @@ -21,8 +21,8 @@ import Pos.Chain.Update (DecidedProposalState (..), LocalVotes, ProposalState (..), UndecidedProposalState (..)) import Pos.Core (Coin, EpochIndex, SlotId (siEpoch), addressHash, applyCoinPortionUp, mkCoin, unsafeAddCoin) -import Pos.Core.Update (UpId, UpdateProposal, UpdateProposals, - UpdateVote (..), bvdUpdateProposalThd) +import Pos.Core.Update (BlockVersionData (..), UpId, UpdateProposal, + UpdateProposals, UpdateVote (..)) import Pos.Crypto (PublicKey, hash) import Pos.DB.Update.Poll.Logic.Apply (verifyAndApplyProposal, verifyAndApplyVoteDo) @@ -35,24 +35,26 @@ import Pos.Util.Wlog (logWarning) -- proposal can be put into a block. normalizePoll :: (MonadPoll m) - => SlotId + => BlockVersionData + -> SlotId -> UpdateProposals -> LocalVotes -> m (UpdateProposals, LocalVotes) -normalizePoll slot proposals votes = - (,) <$> normalizeProposals slot (toList proposals) <*> - normalizeVotes (HM.toList votes) +normalizePoll genesisBvd slot proposals votes = + (,) <$> normalizeProposals genesisBvd slot (toList proposals) <*> + normalizeVotes genesisBvd (HM.toList votes) -- | This function can be used to refresh mem pool consisting of given -- proposals and votes. It applies the most valuable data and discards -- everything else. refreshPoll :: (MonadPoll m) - => SlotId + => BlockVersionData + -> SlotId -> UpdateProposals -> LocalVotes -> m (UpdateProposals, LocalVotes) -refreshPoll slot proposals votes = do +refreshPoll genesisBvd slot proposals votes = do proposalsSorted <- sortWithMDesc evaluatePropStake $ toList proposals -- When mempool is exhausted we leave only half of all proposals we have. -- We take proposals which have the greatest stake voted for it. @@ -75,7 +77,9 @@ refreshPoll slot proposals votes = do let otherVotesNum = length otherVotes `div` 2 let bestVotes = votesForBest <> groupVotes (take otherVotesNum otherVotesSorted) - (,) <$> normalizeProposals slot bestProposals <*> normalizeVotes bestVotes + (,) + <$> normalizeProposals genesisBvd slot bestProposals + <*> normalizeVotes genesisBvd bestVotes where evaluatePropStake up = case votes ^. at (hash up) of @@ -89,7 +93,7 @@ refreshPoll slot proposals votes = do in (id, ) <$> votes ^. at id evaluateVoteStake vote = fromMaybe (mkCoin 0) <$> - getRichmanStake (siEpoch slot) (addressHash (uvKey vote)) + getRichmanStake genesisBvd (siEpoch slot) (addressHash (uvKey vote)) groupVotes :: [UpdateVote] -> [(UpId, HashMap PublicKey UpdateVote)] groupVotes = HM.toList . foldl' groupVotesStep mempty groupVotesStep :: LocalVotes -> UpdateVote -> LocalVotes @@ -101,20 +105,20 @@ refreshPoll slot proposals votes = do -- Disregard other proposals. normalizeProposals :: (MonadPoll m) - => SlotId -> [UpdateProposal] -> m UpdateProposals -normalizeProposals slotId (toList -> proposals) = + => BlockVersionData -> SlotId -> [UpdateProposal] -> m UpdateProposals +normalizeProposals genesisBvd slotId (toList -> proposals) = HM.fromList . map ((\x->(hash x, x)) . fst) . catRights proposals <$> -- Here we don't need to verify that attributes are known, because it -- must hold for all proposals in mempool anyway. forM proposals - (runExceptT . verifyAndApplyProposal False (Left slotId) []) + (runExceptT . verifyAndApplyProposal genesisBvd False (Left slotId) []) -- Apply votes which can be applied and put them in result. -- Disregard other votes. normalizeVotes :: forall m . (MonadPoll m) - => [(UpId, HashMap PublicKey UpdateVote)] -> m LocalVotes -normalizeVotes votesGroups = + => BlockVersionData -> [(UpId, HashMap PublicKey UpdateVote)] -> m LocalVotes +normalizeVotes genesisBvd votesGroups = HM.fromList . catMaybes <$> mapM verifyNApplyVotesGroup votesGroups where verifyNApplyVotesGroup :: (UpId, HashMap PublicKey UpdateVote) @@ -130,7 +134,7 @@ normalizeVotes votesGroups = let uvs = toList votesGroup verifiedPKs <- catRights pks <$> - mapM (runExceptT . verifyAndApplyVoteDo Nothing ups) uvs + mapM (runExceptT . verifyAndApplyVoteDo genesisBvd Nothing ups) uvs if | null verifiedPKs -> pure Nothing | otherwise -> pure $ Just ( upId @@ -142,9 +146,13 @@ normalizeVotes votesGroups = -- block according to 'bvdUpdateProposalThd'. Note that this function is -- read-only. filterProposalsByThd - :: forall m . (MonadPollRead m) - => EpochIndex -> UpdateProposals -> m (UpdateProposals, HashSet UpId) -filterProposalsByThd epoch proposalsHM = getEpochTotalStake epoch >>= \case + :: forall m + . (MonadPollRead m) + => BlockVersionData + -> EpochIndex + -> UpdateProposals + -> m (UpdateProposals, HashSet UpId) +filterProposalsByThd genesisBvd epoch proposalsHM = getEpochTotalStake genesisBvd epoch >>= \case Nothing -> (mempty, getKeys proposalsHM) <$ logWarning diff --git a/db/src/Pos/DB/Update/Poll/Logic/Softfork.hs b/db/src/Pos/DB/Update/Poll/Logic/Softfork.hs index a646f14e8e8..7c0a3b417a8 100644 --- a/db/src/Pos/DB/Update/Poll/Logic/Softfork.hs +++ b/db/src/Pos/DB/Update/Poll/Logic/Softfork.hs @@ -20,8 +20,10 @@ import Serokell.Util.Text (listJson) import Pos.Chain.Block (HeaderHash) import Pos.Chain.Update (BlockVersionState (..), MonadPoll (..), MonadPollRead (..), PollVerFailure (..)) -import Pos.Core (BlockCount, Coin, EpochIndex, SlotCount, SlotId (..), - StakeholderId, crucialSlot, sumCoins, unsafeIntegerToCoin) +import Pos.Core as Core (BlockCount, Coin, Config (..), EpochIndex, + SlotId (..), StakeholderId, configBlockVersionData, + configEpochSlots, crucialSlot, sumCoins, + unsafeIntegerToCoin) import Pos.Core.Update (BlockVersion, BlockVersionData (..), SoftforkRule (..)) import Pos.DB.Update.Poll.Logic.Base (ConfirmedEpoch, CurEpoch, @@ -79,13 +81,14 @@ recordBlockIssuance k id bv slot h = do processGenesisBlock :: forall m . (MonadError PollVerFailure m, MonadPoll m) - => SlotCount + => Core.Config -> EpochIndex -> m () -processGenesisBlock epochSlots epoch = do +processGenesisBlock coreConfig epoch = do -- First thing to do is to obtain values threshold for softfork -- resolution rule check. - totalStake <- note (PollUnknownStakes epoch) =<< getEpochTotalStake epoch + totalStake <- note (PollUnknownStakes epoch) + =<< getEpochTotalStake (configBlockVersionData coreConfig) epoch BlockVersionData {..} <- getAdoptedBVData -- Then we take all competing BlockVersions and actually check softfork -- resolution rule for them. @@ -105,7 +108,7 @@ processGenesisBlock epochSlots epoch = do -- unstable to stable. Just (chooseToAdopt -> toAdopt) -> adoptAndFinish competing toAdopt -- In the end we also update slotting data to the most recent state. - updateSlottingData epochSlots epoch + updateSlottingData (configEpochSlots coreConfig) epoch setEpochProposers mempty where checkThreshold :: diff --git a/db/src/Pos/DB/Update/Poll/Pure.hs b/db/src/Pos/DB/Update/Poll/Pure.hs index ae9447636be..38bc73a27dd 100644 --- a/db/src/Pos/DB/Update/Poll/Pure.hs +++ b/db/src/Pos/DB/Update/Poll/Pure.hs @@ -68,9 +68,9 @@ instance MonadPollRead PurePoll where pure False filterFun (_, Just _) = pure True getConfirmedProposals = PurePoll $ use $ Poll.psConfirmedProposals . to HM.elems - getEpochTotalStake ei = + getEpochTotalStake _ ei = PurePoll $ uses Poll.psFullRichmenData $ (Just . fst) <=< HM.lookup ei - getRichmanStake ei si = + getRichmanStake _ ei si = PurePoll $ uses Poll.psFullRichmenData $ (HM.lookup si . snd) <=< HM.lookup ei getOldProposals si = PurePoll $ uses Poll.psActiveProposals $ filter ((<= si) . upsSlot) . diff --git a/generator/app/VerificationBench.hs b/generator/app/VerificationBench.hs index 73747820c1f..2312b7fabf9 100644 --- a/generator/app/VerificationBench.hs +++ b/generator/app/VerificationBench.hs @@ -19,11 +19,10 @@ import Pos.Binary.Class (decodeFull, serialize) import Pos.Chain.Block (ApplyBlocksException, Block, VerifyBlocksException) import Pos.Chain.Txp (TxpConfiguration (..)) -import Pos.Core as Core (Config (..), configBootStakeholders, - configGeneratedSecretsThrow) +import Pos.Core as Core (Config (..), configBlockVersionData, + configBootStakeholders, configGeneratedSecretsThrow) import Pos.Core.Chrono (NE, OldestFirst (..), nonEmptyNewestFirst) import Pos.Core.Common (BlockCount (..), unsafeCoinPortionFromDouble) -import Pos.Core.Configuration (genesisBlockVersionData) import Pos.Core.Genesis (FakeAvvmOptions (..), GenesisData (..), GenesisInitializer (..), GenesisProtocolConstants (..), TestnetBalanceOptions (..), gsSecretKeys) @@ -202,7 +201,7 @@ main = do withConfigurationsM (LoggerName "verification-bench") Nothing cfo fn $ \ !coreConfig !txpConfig !_ -> do let tp = TestParams { _tpStartTime = Timestamp (convertUnit startTime) - , _tpBlockVersionData = genesisBlockVersionData + , _tpBlockVersionData = configBlockVersionData coreConfig , _tpGenesisInitializer = genesisInitializer , _tpTxpConfiguration = TxpConfiguration 200 Set.empty } diff --git a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs index f1feddcd6c5..c7e6e7f73ac 100644 --- a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs +++ b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs @@ -17,11 +17,11 @@ import Pos.AllSecrets (mkAllSecretsSimple) import Pos.Chain.Block (Block, VerifyBlockParams (..), VerifyHeaderParams (..), getBlockHeader, verifyBlock, verifyHeader) -import Pos.Core as Core (Config (..), configBootStakeholders, - configEpochSlots, configGeneratedSecretsThrow) +import Pos.Core as Core (Config (..), configBlockVersionData, + configBootStakeholders, configEpochSlots, + configGeneratedSecretsThrow) import Pos.Core.Chrono (NE, OldestFirst (..), nonEmptyNewestFirst) import Pos.Core.Common (BlockCount (..), unsafeCoinPortionFromDouble) -import Pos.Core.Configuration (genesisBlockVersionData) import Pos.Core.Genesis (FakeAvvmOptions (..), GenesisInitializer (..), TestnetBalanceOptions (..), gsSecretKeys) @@ -233,7 +233,7 @@ runBenchmark = do $ \coreConfig txpConfig _ -> do let tp = TestParams { _tpStartTime = Timestamp (convertUnit startTime) - , _tpBlockVersionData = genesisBlockVersionData + , _tpBlockVersionData = configBlockVersionData coreConfig , _tpGenesisInitializer = genesisInitializer , _tpTxpConfiguration = txpConfig } diff --git a/generator/src/Test/Pos/Block/Logic/Mode.hs b/generator/src/Test/Pos/Block/Logic/Mode.hs index 15f6cb0e4a6..e006125c5ef 100644 --- a/generator/src/Test/Pos/Block/Logic/Mode.hs +++ b/generator/src/Test/Pos/Block/Logic/Mode.hs @@ -68,8 +68,6 @@ import Pos.Core as Core (Config (..), CoreConfiguration (..), Timestamp (..), configEpochSlots, configGeneratedSecretsThrow, withGenesisSpec) import Pos.Core.Conc (currentTime) -import Pos.Core.Configuration (HasGenesisBlockVersionData, - withGenesisBlockVersionData) import Pos.Core.Genesis (GenesisInitializer (..), GenesisSpec (..), gsSecretKeys) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), @@ -158,13 +156,10 @@ instance Arbitrary TestParams where let _tpStartTime = Timestamp (fromMicroseconds 0) let _tpBlockVersionData = defaultTestBlockVersionData let _tpTxpConfiguration = TxpConfiguration 200 Set.empty - _tpGenesisInitializer <- - withGenesisBlockVersionData - _tpBlockVersionData - genGenesisInitializer + _tpGenesisInitializer <- genGenesisInitializer return TestParams {..} -genGenesisInitializer :: HasGenesisBlockVersionData => Gen GenesisInitializer +genGenesisInitializer :: Gen GenesisInitializer genGenesisInitializer = do giTestBalance <- arbitrary giFakeAvvmBalance <- arbitrary diff --git a/generator/test/Test/Pos/Block/Logic/CreationSpec.hs b/generator/test/Test/Pos/Block/Logic/CreationSpec.hs index e7a7300f505..b67faa3e4c0 100644 --- a/generator/test/Test/Pos/Block/Logic/CreationSpec.hs +++ b/generator/test/Test/Pos/Block/Logic/CreationSpec.hs @@ -22,8 +22,8 @@ import Pos.Chain.Delegation (DlgPayload, ProxySKBlockInfo) import Pos.Chain.Ssc (defaultSscPayload) import Pos.Chain.Update (HasUpdateConfiguration) import qualified Pos.Communication () -import Pos.Core (SlotId (..), genesisBlockVersionData, - localSlotIndexMinBound, unsafeMkLocalSlotIndex) +import Pos.Core (SlotId (..), localSlotIndexMinBound, + unsafeMkLocalSlotIndex) import Pos.Core.Ssc (SscPayload (..), mkVssCertificatesMapLossy) import Pos.Core.Txp (TxAux) import Pos.Core.Update (BlockVersionData (..), UpdatePayload (..)) @@ -34,16 +34,15 @@ import Test.Pos.Chain.Block.Arbitrary () import Test.Pos.Chain.Delegation.Arbitrary (genDlgPayload) import Test.Pos.Chain.Ssc.Arbitrary (commitmentMapEpochGen, vssCertificateEpochGen) -import Test.Pos.Configuration (withDefConfiguration, - withDefUpdateConfiguration) +import Test.Pos.Configuration (withDefUpdateConfiguration) import Test.Pos.Core.Arbitrary.Txp (GoodTx, goodTxToTxAux) -import Test.Pos.Core.Dummy (dummyConfig, dummyEpochSlots, dummyK, - dummyProtocolConstants) +import Test.Pos.Core.Dummy (dummyBlockVersionData, dummyConfig, + dummyEpochSlots, dummyK, dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck (SmallGenerator (..), makeSmall) spec :: Spec -spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ +spec = withDefUpdateConfiguration $ describe "Block.Logic.Creation" $ do -- Sampling the minimum empty block size @@ -67,7 +66,7 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ -- bytes; this is *completely* independent of encoding used. -- Empirically, empty blocks don't get bigger than 550 -- bytes. - s <= 550 && s <= bvdMaxBlockSize genesisBlockVersionData + s <= 550 && s <= bvdMaxBlockSize dummyBlockVersionData prop "doesn't create blocks bigger than the limit" $ forAll (choose (emptyBSize, emptyBSize * 10)) $ \(fromBytes -> limit) -> forAll arbitrary $ \(prevHeader, sk, updatePayload) -> diff --git a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs index b82ee885116..432bfdd3628 100644 --- a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs +++ b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs @@ -28,9 +28,9 @@ import qualified Pos.Chain.Lrc as Lrc import Pos.Chain.Txp (TxpConfiguration (..)) import Pos.Core as Core (Coin, Config (..), EpochIndex, StakeholderId, addressHash, coinF, configBlkSecurityParam, - configEpochSlots, configFtsSeed, + configBlockVersionData, configEpochSlots, configFtsSeed, configGeneratedSecretsThrow) -import Pos.Core.Genesis (GeneratedSecrets, GenesisInitializer (..), +import Pos.Core.Genesis (GenesisInitializer (..), TestnetBalanceOptions (..), gsSecretKeysPoor, gsSecretKeysRich) import Pos.Core.Txp (TxAux, mkTxPayload) @@ -184,21 +184,18 @@ lrcCorrectnessProp coreConfig txpConfig = do ", computed leaders: "%listJson) expectedLeadersStakes leaders1 - generatedSecrets <- configGeneratedSecretsThrow coreConfig - checkRichmen generatedSecrets + checkRichmen coreConfig -checkRichmen :: HasConfigurations => GeneratedSecrets -> BlockProperty () -checkRichmen generatedSecrets = do - checkRichmenStakes =<< getRichmen (lift . LrcDB.tryGetSscRichmen) - checkRichmenFull =<< getRichmen (lift . LrcDB.tryGetUSRichmen) - checkRichmenSet =<< getRichmen (lift . LrcDB.tryGetDlgRichmen) +checkRichmen :: HasConfigurations => Core.Config -> BlockProperty () +checkRichmen coreConfig = do + checkRichmenStakes =<< getRichmen (lift . LrcDB.tryGetSscRichmen genesisBvd) + checkRichmenFull =<< getRichmen (lift . LrcDB.tryGetUSRichmen genesisBvd) + checkRichmenSet =<< getRichmen (lift . LrcDB.tryGetDlgRichmen genesisBvd) where + genesisBvd = configBlockVersionData coreConfig + toStakeholders :: [SecretKey] -> [StakeholderId] toStakeholders = map (addressHash . toPublic) - poorStakeholders :: [StakeholderId] - poorStakeholders = toStakeholders $ gsSecretKeysPoor generatedSecrets - richStakeholders :: [StakeholderId] - richStakeholders = toStakeholders $ gsSecretKeysRich generatedSecrets getRichmen :: (EpochIndex -> BlockProperty (Maybe richmen)) @@ -230,6 +227,8 @@ checkRichmen generatedSecrets = do checkRichmenSet :: Lrc.RichmenSet -> BlockProperty () checkRichmenSet richmenSet = do + poorStakeholders <- toStakeholders . gsSecretKeysPoor + <$> configGeneratedSecretsThrow coreConfig mapM_ (checkPoor richmenSet) poorStakeholders let checkRich (id, realStake) = when (isNothing (richmenSet ^. at id)) $ @@ -240,6 +239,8 @@ checkRichmen generatedSecrets = do expectedRichmenStakes :: BlockProperty [(StakeholderId, Coin)] expectedRichmenStakes = do + richStakeholders <- toStakeholders . gsSecretKeysRich + <$> configGeneratedSecretsThrow coreConfig let resolve id = (id, ) . fromMaybe minBound <$> GS.getRealStake id lift $ mapM resolve richStakeholders diff --git a/lib/src/Pos/GState/GState.hs b/lib/src/Pos/GState/GState.hs index b407be901f8..47075851a18 100644 --- a/lib/src/Pos/GState/GState.hs +++ b/lib/src/Pos/GState/GState.hs @@ -32,7 +32,7 @@ prepareGStateDB coreConfig initialTip = unlessM isInitialized $ do initGStateUtxo genesisData initSscDB $ configVssCerts coreConfig initGStateStakes genesisData - initGStateUS $ configProtocolConstants coreConfig + initGStateUS coreConfig initGStateDlg $ configHeavyDelegation coreConfig initGStateBlockExtra (configGenesisHash coreConfig) initialTip diff --git a/lib/src/Pos/Listener/Delegation.hs b/lib/src/Pos/Listener/Delegation.hs index 795e85f46dd..b55cdf1bcba 100644 --- a/lib/src/Pos/Listener/Delegation.hs +++ b/lib/src/Pos/Listener/Delegation.hs @@ -14,8 +14,8 @@ import Formatting (build, sformat, shown, (%)) import UnliftIO (MonadUnliftIO) import Pos.Chain.Delegation (HasDlgConfiguration, MonadDelegation) +import Pos.Core as Core (Config) import Pos.Core.Delegation (ProxySKHeavy) -import Pos.Crypto (ProtocolMagic) import Pos.DB.Class (MonadBlockDBRead, MonadGState) import Pos.DB.Delegation (PskHeavyVerdict (..), processProxySKHeavy) import Pos.DB.Lrc (HasLrcContext) @@ -45,10 +45,11 @@ type DlgListenerConstraint ctx m , HasDlgConfiguration ) -handlePsk :: (DlgListenerConstraint ctx m) => ProtocolMagic -> ProxySKHeavy -> m Bool -handlePsk pm pSk = do +handlePsk + :: (DlgListenerConstraint ctx m) => Core.Config -> ProxySKHeavy -> m Bool +handlePsk coreConfig pSk = do logDebug $ sformat ("Got request to handle heavyweight psk: "%build) pSk - verdict <- processProxySKHeavy pm pSk + verdict <- processProxySKHeavy coreConfig pSk logDebug $ sformat ("The verdict for cert "%build%" is: "%shown) pSk verdict case verdict of PHTipMismatch -> do @@ -56,7 +57,7 @@ handlePsk pm pSk = do -- leaders can be calculated incorrectly. This is -- really weird and must not happen. We'll just retry. logWarning "Tip mismatch happened in delegation db!" - handlePsk pm pSk + handlePsk coreConfig pSk PHAdded -> pure True PHRemoved -> pure True _ -> pure False diff --git a/lib/src/Pos/Logic/Full.hs b/lib/src/Pos/Logic/Full.hs index 4fabb0cc5d5..112d7f13e50 100644 --- a/lib/src/Pos/Logic/Full.hs +++ b/lib/src/Pos/Logic/Full.hs @@ -156,7 +156,7 @@ logicFull coreConfig txpConfig ourStakeholderId securityParams jsonLogTx = postBlockHeader = Block.handleUnsolicitedHeader coreConfig postPskHeavy :: ProxySKHeavy -> m Bool - postPskHeavy = Delegation.handlePsk $ configProtocolMagic coreConfig + postPskHeavy = Delegation.handlePsk coreConfig postTx = KeyVal { toKey = pure . Tagged . hash . taTx . getTxMsgContents diff --git a/lib/src/Pos/Worker.hs b/lib/src/Pos/Worker.hs index d56ab8a8fbd..8d09d70905a 100644 --- a/lib/src/Pos/Worker.hs +++ b/lib/src/Pos/Worker.hs @@ -14,8 +14,7 @@ import Pos.Worker.Block (blkWorkers) -- Message instances. import Pos.Chain.Txp (TxpConfiguration) import Pos.Context (NodeContext (..)) -import Pos.Core as Core (Config, configBlkSecurityParam, - configEpochSlots) +import Pos.Core as Core (Config, configEpochSlots) import Pos.Infra.Diffusion.Types (Diffusion) import Pos.Infra.Network.CLI (launchStaticConfigMonitoring) import Pos.Infra.Network.Types (NetworkConfig (..)) @@ -35,7 +34,7 @@ allWorkers -> [Diffusion m -> m ()] allWorkers coreConfig txpConfig NodeResources {..} = mconcat [ sscWorkers coreConfig - , usWorkers (configBlkSecurityParam coreConfig) + , usWorkers coreConfig , blkWorkers coreConfig txpConfig , dlgWorkers , [properSlottingWorker, staticConfigMonitoringWorker] diff --git a/lib/src/Pos/Worker/Ssc.hs b/lib/src/Pos/Worker/Ssc.hs index 967442a20ba..92cd6fefe08 100644 --- a/lib/src/Pos/Worker/Ssc.hs +++ b/lib/src/Pos/Worker/Ssc.hs @@ -34,9 +34,10 @@ import Pos.Chain.Ssc (HasSscConfiguration, HasSscContext (..), sgsCommitments, vssThreshold) import Pos.Core as Core (BlockCount, Config (..), EpochIndex, HasPrimaryKey, SlotId (..), StakeholderId, Timestamp (..), - configBlkSecurityParam, configEpochSlots, configVssMaxTTL, - getOurSecretKey, getOurStakeholderId, getSlotIndex, - kEpochSlots, kSlotSecurityParam, mkLocalSlotIndex) + configBlkSecurityParam, configBlockVersionData, + configEpochSlots, configVssMaxTTL, getOurSecretKey, + getOurStakeholderId, getSlotIndex, kEpochSlots, + kSlotSecurityParam, mkLocalSlotIndex) import Pos.Core.Conc (currentTime, delay) import Pos.Core.JsonLog (CanJsonLog) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), @@ -45,7 +46,7 @@ import Pos.Core.Ssc (InnerSharesMap, Opening, SignedCommitment, VssCertificate (..), VssCertificatesMap (..), getCommitmentsMap, lookupVss, memberVss, mkVssCertificate, randCommitmentAndOpening) -import Pos.Core.Update (bvdMpcThd) +import Pos.Core.Update (BlockVersionData (..)) import Pos.Crypto (SecretKey, VssKeyPair, VssPublicKey, randomNumber, randomNumberInRange, runSecureRandom, vssKeyGen) import Pos.Crypto.SecretSharing (toVssPublicKey) @@ -99,12 +100,12 @@ sscWorkers -> [Diffusion m -> m ()] sscWorkers coreConfig = [ onNewSlotSsc coreConfig - , checkForIgnoredCommitmentsWorker (configBlkSecurityParam coreConfig) + , checkForIgnoredCommitmentsWorker coreConfig ] -shouldParticipate :: SscMode ctx m => EpochIndex -> m Bool -shouldParticipate epoch = do - richmen <- getSscRichmen "shouldParticipate" epoch +shouldParticipate :: SscMode ctx m => BlockVersionData -> EpochIndex -> m Bool +shouldParticipate genesisBvd epoch = do + richmen <- getSscRichmen genesisBvd "shouldParticipate" epoch participationEnabled <- view sscContext >>= (readTVarIO . scParticipateSsc) ourId <- getOurStakeholderId @@ -123,7 +124,7 @@ onNewSlotSsc onNewSlotSsc coreConfig diffusion = onNewSlot (configEpochSlots coreConfig) defaultOnNewSlotParams $ \slotId -> recoveryCommGuard (configBlkSecurityParam coreConfig) "onNewSlot worker in SSC" $ do sscGarbageCollectLocalData slotId - whenM (shouldParticipate $ siEpoch slotId) $ do + whenM (shouldParticipate (configBlockVersionData coreConfig) $ siEpoch slotId) $ do behavior <- view sscContext >>= (readTVarIO . scBehavior) checkNSendOurCert coreConfig (sendSscCert diffusion) @@ -359,7 +360,9 @@ generateAndSetNewSecret -> SlotId -- ^ Current slot -> m (Maybe SignedCommitment) generateAndSetNewSecret coreConfig sk SlotId {..} = do - richmen <- getSscRichmen "generateAndSetNewSecret" siEpoch + richmen <- getSscRichmen (configBlockVersionData coreConfig) + "generateAndSetNewSecret" + siEpoch certs <- getStableCerts coreConfig siEpoch inAssertMode $ do let participantIds = @@ -452,14 +455,14 @@ checkForIgnoredCommitmentsWorker ( SscMode ctx m , HasMisbehaviorMetrics ctx ) - => BlockCount + => Core.Config -> Diffusion m -> m () -checkForIgnoredCommitmentsWorker k _ = do +checkForIgnoredCommitmentsWorker coreConfig _ = do counter <- newTVarIO 0 - onNewSlot (kEpochSlots k) + onNewSlot (configEpochSlots coreConfig) defaultOnNewSlotParams - (checkForIgnoredCommitmentsWorkerImpl k counter) + (checkForIgnoredCommitmentsWorkerImpl coreConfig counter) -- This worker checks whether our commitments appear in blocks. This check -- is done only if we actually should participate in SSC. It's triggered if @@ -475,13 +478,13 @@ checkForIgnoredCommitmentsWorkerImpl ( SscMode ctx m , HasMisbehaviorMetrics ctx ) - => BlockCount -> TVar Word -> SlotId -> m () -checkForIgnoredCommitmentsWorkerImpl k counter SlotId {..} + => Core.Config -> TVar Word -> SlotId -> m () +checkForIgnoredCommitmentsWorkerImpl coreConfig counter SlotId {..} -- It's enough to do this check once per epoch near the end of the epoch. - | getSlotIndex siSlot /= 9 * fromIntegral k = pass + | getSlotIndex siSlot /= 9 * fromIntegral (configBlkSecurityParam coreConfig) = pass | otherwise = - recoveryCommGuard k "checkForIgnoredCommitmentsWorker" $ - whenM (shouldParticipate siEpoch) $ do + recoveryCommGuard (configBlkSecurityParam coreConfig) "checkForIgnoredCommitmentsWorker" $ + whenM (shouldParticipate (configBlockVersionData coreConfig) siEpoch) $ do ourId <- getOurStakeholderId globalCommitments <- getCommitmentsMap . view sgsCommitments <$> sscGetGlobalState diff --git a/lib/src/Pos/Worker/Update.hs b/lib/src/Pos/Worker/Update.hs index 9c154133bd0..f15f688d83d 100644 --- a/lib/src/Pos/Worker/Update.hs +++ b/lib/src/Pos/Worker/Update.hs @@ -13,7 +13,8 @@ import Serokell.Util.Text (listJsonIndent) import Pos.Chain.Update (ConfirmedProposalState (..), curSoftwareVersion) -import Pos.Core (BlockCount, kEpochSlots) +import Pos.Core as Core (Config (..), configBlkSecurityParam, + configBlockVersionData, configEpochSlots) import Pos.Core.Update (SoftwareVersion (..), UpdateProposal (..)) import Pos.DB.Update (UpdateContext (..), getConfirmedProposals, processNewSlot) @@ -29,9 +30,11 @@ import Pos.Util.Wlog (logDebug, logInfo) -- | Update System related workers. usWorkers - :: forall ctx m . UpdateMode ctx m => BlockCount -> [Diffusion m -> m ()] -usWorkers k = [processNewSlotWorker, checkForUpdateWorker] + :: forall ctx m . UpdateMode ctx m => Core.Config -> [Diffusion m -> m ()] +usWorkers coreConfig = [processNewSlotWorker, checkForUpdateWorker] where + epochSlots = configEpochSlots coreConfig + k = configBlkSecurityParam coreConfig -- These are two separate workers. We want them to run in parallel -- and not affect each other. processNewSlotParams = defaultOnNewSlotParams @@ -39,12 +42,12 @@ usWorkers k = [processNewSlotWorker, checkForUpdateWorker] "Update.processNewSlot" } processNewSlotWorker _ = - onNewSlot (kEpochSlots k) processNewSlotParams $ \s -> + onNewSlot epochSlots processNewSlotParams $ \s -> recoveryCommGuard k "processNewSlot in US" $ do logDebug "Updating slot for US..." - processNewSlot s + processNewSlot (configBlockVersionData coreConfig) s checkForUpdateWorker _ = - onNewSlot (kEpochSlots k) defaultOnNewSlotParams $ \_ -> + onNewSlot epochSlots defaultOnNewSlotParams $ \_ -> recoveryCommGuard k "checkForUpdate" (checkForUpdate @ctx @m) checkForUpdate :: diff --git a/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs b/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs index a999d4e8367..bf8fe3cab0b 100644 --- a/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs +++ b/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs @@ -30,9 +30,8 @@ import Pos.Chain.Ssc (MultiRichmenStakes, PureTossWithEnv, sgsCommitments, sgsOpenings, sgsShares, sgsVssCertificates, supplyPureTossEnv, verifyCommitment, verifyCommitmentSignature, verifyOpening) -import Pos.Core (Coin, EpochIndex, EpochOrSlot (..), HasConfiguration, - StakeholderId, addressHash, crucialSlot, - genesisBlockVersionData, mkCoin) +import Pos.Core (Coin, EpochIndex, EpochOrSlot (..), StakeholderId, + addressHash, crucialSlot, mkCoin) import Pos.Core.Ssc (Commitment, CommitmentSignature, CommitmentsMap (..), InnerSharesMap, Opening, OpeningsMap, SharesMap, SignedCommitment, VssCertificate (..), @@ -46,12 +45,12 @@ import Test.Pos.Util.QuickCheck.Property (qcElem, qcFail, qcIsRight) import Test.Pos.Chain.Ssc.Arbitrary (BadCommAndOpening (..), BadSignedCommitment (..), CommitmentOpening (..)) -import Test.Pos.Configuration (withDefConfiguration) -import Test.Pos.Core.Dummy (dummyConfig, dummyK) +import Test.Pos.Core.Dummy (dummyBlockVersionData, dummyConfig, + dummyK) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) spec :: Spec -spec = withDefConfiguration $ \_ -> describe "Ssc.Base" $ do +spec = describe "Ssc.Base" $ do describe "verifyCommitment" $ do prop description_verifiesOkComm verifiesOkComm describe "verifyCommitmentSignature" $ do @@ -139,7 +138,7 @@ notVerifiesBadOpening (getBadCAndO -> badCommsAndOp) = not . uncurry verifyOpening $ badCommsAndOp emptyPayload - :: (HasConfiguration, Monoid container, Show e) + :: (Monoid container, Show e) => (container -> ExceptT e PureTossWithEnv a) -> MultiRichmenStakes -> SscGlobalState @@ -148,8 +147,7 @@ emptyPayload pureToss mrs sgs = qcIsRight $ tossRunner mrs sgs $ pureToss mempty emptyPayloadComms - :: HasConfiguration - => GoodCommsPayload + :: GoodCommsPayload -> SscGlobalState -> Property -- The 'checkCommitmentsPayload' function will never pass without a valid @@ -171,7 +169,7 @@ data GoodPayload p = GoodPayload type GoodCommsPayload = GoodPayload CommitmentsMap -instance HasConfiguration => Arbitrary GoodCommsPayload where +instance Arbitrary GoodCommsPayload where arbitrary = do -- These fields won't be needed for anything, so they can be entirely arbitrary. _sgsOpenings <- arbitrary @@ -216,7 +214,7 @@ instance HasConfiguration => Arbitrary GoodCommsPayload where return GoodPayload {..} -- TODO: Account for 'CommSharesOnWrongParticipants' failure -checksGoodCommsPayload :: HasConfiguration => GoodCommsPayload -> Bool +checksGoodCommsPayload :: GoodCommsPayload -> Bool checksGoodCommsPayload (GoodPayload epoch sgs commsMap mrs) = case tossRunner mrs sgs $ checkCommitmentsPayload dummyConfig epoch commsMap of Left (CommSharesOnWrongParticipants _) -> True @@ -225,8 +223,7 @@ checksGoodCommsPayload (GoodPayload epoch sgs commsMap mrs) = -- TODO: Account for 'CommSharesOnWrongParticipants' failure checksBadCommsPayload - :: HasConfiguration - => GoodCommsPayload + :: GoodCommsPayload -> StakeholderId -> SignedCommitment -> Int @@ -281,7 +278,7 @@ newtype GoodOpeningPayload = GoodOpens { getGoodOpens :: (SscGlobalState, OpeningsMap) } deriving (Show, Eq) -instance HasConfiguration => Arbitrary GoodOpeningPayload where +instance Arbitrary GoodOpeningPayload where arbitrary = GoodOpens <$> do -- These fields won't be used, so they can be entirely arbitrary @@ -321,15 +318,12 @@ instance HasConfiguration => Arbitrary GoodOpeningPayload where return (SscGlobalState {..}, opensPayload) -checksGoodOpeningsPayload - :: HasConfiguration - => MultiRichmenStakes -> GoodOpeningPayload -> Property +checksGoodOpeningsPayload :: MultiRichmenStakes -> GoodOpeningPayload -> Property checksGoodOpeningsPayload mrs (getGoodOpens -> (sgs, openPayload)) = qcIsRight . tossRunner mrs sgs $ checkOpeningsPayload openPayload checksBadOpeningsPayload - :: HasConfiguration - => StakeholderId + :: StakeholderId -> Opening -> SignedCommitment -> MultiRichmenStakes @@ -370,7 +364,7 @@ checksBadOpeningsPayload type GoodSharesPayload = GoodPayload SharesMap -instance HasConfiguration => Arbitrary GoodSharesPayload where +instance Arbitrary GoodSharesPayload where arbitrary = do -- These openings won't be needed for anything, so they can be entirely arbitrary. _sgsOpenings <- arbitrary @@ -427,7 +421,7 @@ instance HasConfiguration => Arbitrary GoodSharesPayload where -- NOTE: this test does not care for 'DecrSharesNotMatchCommitment' failure. This would --make the already non-trivial arbitrary instance for 'GoodSharesPayload' unmanageable. -checksGoodSharesPayload :: HasConfiguration => GoodSharesPayload -> Bool +checksGoodSharesPayload :: GoodSharesPayload -> Bool checksGoodSharesPayload (GoodPayload epoch sgs sharesMap mrs) = case tossRunner mrs sgs $ checkSharesPayload dummyConfig epoch sharesMap of Left (DecrSharesNotMatchCommitment _) -> True @@ -439,8 +433,7 @@ checksGoodSharesPayload (GoodPayload epoch sgs sharesMap mrs) = -- NOTE: does not check for 'DecrSharesNotMatchCommitment' failure. This would make the -- already non-trivial arbitrary instance for 'GoodSharesPayload' unmanageable. checksBadSharesPayload - :: HasConfiguration - => GoodSharesPayload + :: GoodSharesPayload -> PublicKey -> NonEmpty (AsBinary DecShare) -> VssCertificate @@ -503,7 +496,7 @@ checksBadSharesPayload (GoodPayload epoch g@SscGlobalState {..} sm mrs) pk ne ce type GoodCertsPayload = GoodPayload VssCertificatesMap -instance HasConfiguration => Arbitrary GoodCertsPayload where +instance Arbitrary GoodCertsPayload where arbitrary = do -- These fields of 'SscGlobalState' are irrelevant for the @@ -572,11 +565,11 @@ instance HasConfiguration => Arbitrary GoodCertsPayload where return GoodPayload {..} -checksGoodCertsPayload :: HasConfiguration => GoodCertsPayload -> Property +checksGoodCertsPayload :: GoodCertsPayload -> Property checksGoodCertsPayload (GoodPayload epoch sgs certsMap mrs) = qcIsRight . tossRunner mrs sgs $ checkCertificatesPayload epoch certsMap -checksBadCertsPayload :: HasConfiguration => GoodCertsPayload -> PublicKey -> VssCertificate -> Property +checksBadCertsPayload :: GoodCertsPayload -> PublicKey -> VssCertificate -> Property checksBadCertsPayload (GoodPayload epoch sgs certsMap mrs) pk cert = let sid = addressHash pk @@ -636,8 +629,7 @@ checksBadCertsPayload (GoodPayload epoch sgs certsMap mrs) pk cert = -- Going to use fake randomness here because threading MonadRandom through -- everything is annoying -tossRunner :: HasConfiguration - => MultiRichmenStakes +tossRunner :: MultiRichmenStakes -> SscGlobalState -> ExceptT e PureTossWithEnv a -> Either e a @@ -645,7 +637,7 @@ tossRunner mrs sgs = view _1 . fst . Rand.withDRG (Rand.drgNewTest (123,456,789,12345,67890)) . runPureToss sgs . - supplyPureTossEnv (mrs, genesisBlockVersionData) . + supplyPureTossEnv (mrs, dummyBlockVersionData) . runExceptT customHashMapGen diff --git a/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs b/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs index bb9d1f27170..32da94e1faa 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs @@ -69,8 +69,8 @@ import Pos.Chain.Update (ConfirmedProposalState, import qualified Pos.Chain.Update as Upd import Pos.Context (NodeContext (..)) import Pos.Core as Core (BlockCount, Config (..), GenesisHash (..), - SlotCount, Timestamp, TxFeePolicy, configEpochSlots, - configK, difficultyL, genesisBlockVersionData, + SlotCount, Timestamp, TxFeePolicy, configBlockVersionData, + configEpochSlots, configK, difficultyL, getChainDifficulty) import Pos.Core.Configuration (HasConfiguration) import Pos.Core.Slotting (EpochIndex (..), HasSlottingVar (..), @@ -557,15 +557,16 @@ mockNodeState :: (HasCallStack, MonadThrow m) mockNodeState MockNodeStateParams{..} = withDefConfiguration $ \coreConfig -> withDefUpdateConfiguration $ - Adaptor { + let genesisBvd = configBlockVersionData coreConfig + in Adaptor { withNodeState = \_ -> throwM $ NodeStateUnavailable callStack , getTipSlotId = return mockNodeStateTipSlotId , getSecurityParameter = return mockNodeStateSecurityParameter , getNextEpochSlotDuration = return mockNodeStateNextEpochSlotDuration , getNodeSyncProgress = \_ -> return mockNodeStateSyncProgress , getSlotStart = return . mockNodeStateSlotStart - , getMaxTxSize = return $ bvdMaxTxSize genesisBlockVersionData - , getFeePolicy = return $ bvdTxFeePolicy genesisBlockVersionData + , getMaxTxSize = return $ bvdMaxTxSize genesisBvd + , getFeePolicy = return $ bvdTxFeePolicy genesisBvd , getSlotCount = return $ configEpochSlots coreConfig , getCoreConfig = return coreConfig , curSoftwareVersion = return $ Upd.curSoftwareVersion diff --git a/wallet-new/test/unit/UTxO/Translate.hs b/wallet-new/test/unit/UTxO/Translate.hs index 84e8db909e6..c06a787e7f4 100644 --- a/wallet-new/test/unit/UTxO/Translate.hs +++ b/wallet-new/test/unit/UTxO/Translate.hs @@ -40,7 +40,7 @@ import UTxO.Context import UTxO.Verify (Verify) import qualified UTxO.Verify as Verify -import Test.Pos.Core.Dummy (dummyEpochSlots) +import Test.Pos.Core.Dummy (dummyBlockVersionData, dummyEpochSlots) {------------------------------------------------------------------------------- Testing infrastructure from cardano-sl-core @@ -95,7 +95,7 @@ instance Monad m => MonadReader TransCtxt (TranslateT e m) where -- | Right now this always returns the genesis policy instance Monad m => MonadGState (TranslateT e m) where - gsAdoptedBVData = withConfig $ return genesisBlockVersionData + gsAdoptedBVData = pure dummyBlockVersionData -- | Run translation -- diff --git a/wallet-new/test/unit/UTxO/Verify.hs b/wallet-new/test/unit/UTxO/Verify.hs index db615bacf90..a35a199cebd 100644 --- a/wallet-new/test/unit/UTxO/Verify.hs +++ b/wallet-new/test/unit/UTxO/Verify.hs @@ -42,8 +42,8 @@ import qualified Pos.Util.Modifier as MM import Pos.Util.Wlog import Serokell.Util.Verify -import Test.Pos.Core.Dummy (dummyConfig, dummyEpochSlots, - dummyGenesisData, dummyK) +import Test.Pos.Core.Dummy (dummyBlockVersionData, dummyConfig, + dummyEpochSlots, dummyGenesisData, dummyK) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) {------------------------------------------------------------------------------- @@ -78,11 +78,11 @@ verifyEnv' utxo bvd lname = UnsafeVerifyEnv { } where bootStakeholders = gdBootStakeholders dummyGenesisData -verifyEnv :: HasConfiguration => Utxo -> VerifyEnv +verifyEnv :: Utxo -> VerifyEnv verifyEnv utxo = verifyEnv' utxo - genesisBlockVersionData + dummyBlockVersionData "verify" {------------------------------------------------------------------------------- @@ -112,10 +112,6 @@ instance HasLoggerName WithVerifyEnv where The verification monad is set up to facilitate 'verifyToil', which seems to be the workhorse of verification (verifying transactions inside a block). - - NOTE: Ideally we'd hide 'HasConfiguration' here in the same way that we did - for 'Translate', but this is made impossible by the superclass constraint of - 'MonadUtxoRead'. -------------------------------------------------------------------------------} newtype Verify e a = Verify { @@ -128,7 +124,7 @@ newtype Verify e a = Verify { -- | Run the verifier -- -- Returns the result of verification as well as the final UTxO. -verify :: HasConfiguration => Utxo -> Verify e a -> Either e (a, Utxo) +verify :: Utxo -> Verify e a -> Either e (a, Utxo) verify utxo ma = second finalUtxo <$> verify' (defGlobalToilState, []) (verifyEnv utxo) ma