From da9fc0f6b325c194d5c705d67ed57d4b5b1c840d Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Wed, 13 Jun 2018 09:20:21 -0700 Subject: [PATCH] [CDEC-369] Remove HasProtocolConstants in favour of parameters --- auxx/Main.hs | 93 +++++--- auxx/src/Command/BlockGen.hs | 50 ++-- auxx/src/Command/Proc.hs | 51 ++-- auxx/src/Command/Rollback.hs | 64 ++--- auxx/src/Command/Tx.hs | 68 ++++-- auxx/src/Mode.hs | 40 ++-- auxx/src/Plugin.hs | 55 ++--- block/bench/Block.hs | 12 +- block/src/Pos/Block/BHelpers.hs | 14 +- block/src/Pos/Block/BListener.hs | 5 +- block/src/Pos/Block/Logic/Creation.hs | 182 +++++++------- block/src/Pos/Block/Logic/Header.hs | 47 ++-- block/src/Pos/Block/Logic/Integrity.hs | 23 +- block/src/Pos/Block/Logic/Internal.hs | 79 +++--- block/src/Pos/Block/Logic/Util.hs | 48 ++-- block/src/Pos/Block/Logic/VAR.hs | 63 ++--- block/src/Pos/Block/Lrc.hs | 32 +-- block/src/Pos/Block/Network/Logic.hs | 151 ++++++------ block/src/Pos/Block/Network/Retrieval.hs | 65 ++--- block/src/Pos/Block/Slog/Context.hs | 16 +- block/src/Pos/Block/Slog/Logic.hs | 36 +-- block/src/Pos/Block/Slog/Types.hs | 17 +- block/src/Pos/Block/Types.hs | 25 +- block/src/Pos/Block/Worker.hs | 224 +++++++++--------- block/src/Pos/GState/BlockExtra.hs | 22 +- block/test/Test/Pos/Block/Arbitrary.hs | 85 +++---- .../test/Test/Pos/Block/Arbitrary/Generate.hs | 15 +- .../test/Test/Pos/Block/Arbitrary/Message.hs | 11 +- client/cardano-sl-client.cabal | 1 + client/src/Pos/Client/Txp/Addresses.hs | 6 +- client/src/Pos/Client/Txp/History.hs | 25 +- client/src/Pos/Client/Txp/Network.hs | 18 +- client/src/Pos/Client/Txp/Util.hs | 104 +++++--- client/test/Test/Pos/Client/Txp/Mode.hs | 8 +- client/test/Test/Pos/Client/Txp/UtilSpec.hs | 47 ++-- core/cardano-sl-core.cabal | 2 +- core/src/Pos/Core/Configuration.hs | 15 +- core/src/Pos/Core/Configuration/Protocol.hs | 70 ------ core/src/Pos/Core/Genesis/Generate.hs | 21 +- core/src/Pos/Core/ProtocolConstants.hs | 51 +++- core/src/Pos/Core/Slotting/EpochOrSlot.hs | 120 ++++++---- core/src/Pos/Core/Slotting/LocalSlotIndex.hs | 79 +++--- core/src/Pos/Core/Slotting/SlotId.hs | 71 +++--- core/test/Test/Pos/Core/Arbitrary.hs | 38 +-- core/test/Test/Pos/Core/Arbitrary/Unsafe.hs | 5 +- core/test/Test/Pos/Core/Bi.hs | 30 +-- core/test/Test/Pos/Core/CborSpec.hs | 2 +- core/test/Test/Pos/Core/Dummy.hs | 26 ++ core/test/Test/Pos/Core/Gen.hs | 51 ++-- core/test/Test/Pos/Core/SlottingSpec.hs | 97 +++++--- core/test/cardano-sl-core-test.cabal | 1 + .../bench/Bench/Pos/Explorer/ServerBench.hs | 10 +- explorer/cardano-sl-explorer.cabal | 2 + explorer/src/Pos/Explorer/BListener.hs | 4 +- explorer/src/Pos/Explorer/DB.hs | 18 +- explorer/src/Pos/Explorer/ExplorerMode.hs | 21 +- explorer/src/Pos/Explorer/Socket/App.hs | 33 +-- explorer/src/Pos/Explorer/Socket/Methods.hs | 20 +- explorer/src/Pos/Explorer/TestUtil.hs | 44 ++-- explorer/src/Pos/Explorer/Txp/Global.hs | 13 +- explorer/src/Pos/Explorer/Txp/Local.hs | 63 +++-- explorer/src/Pos/Explorer/Web/ClientTypes.hs | 25 +- explorer/src/Pos/Explorer/Web/Server.hs | 69 +++--- explorer/src/Pos/Explorer/Web/Transform.hs | 23 +- explorer/src/explorer/Main.hs | 71 +++--- .../test/Test/Pos/Explorer/Web/ServerSpec.hs | 11 +- generator/cardano-sl-generator.cabal | 2 + generator/src/Pos/Generator/Block/Logic.hs | 115 +++++---- generator/src/Pos/Generator/Block/Mode.hs | 37 ++- generator/src/Pos/Generator/Block/Payload.hs | 12 +- generator/src/Pos/Generator/BlockEvent.hs | 22 +- generator/src/Pos/Generator/BlockEvent/DSL.hs | 12 +- generator/src/Test/Pos/Block/Logic/Event.hs | 23 +- generator/src/Test/Pos/Block/Logic/Mode.hs | 63 +++-- generator/src/Test/Pos/Block/Logic/Util.hs | 44 ++-- .../test/Test/Pos/Binary/CommunicationSpec.hs | 11 +- .../test/Test/Pos/Block/Logic/CreationSpec.hs | 173 ++++++++------ .../test/Test/Pos/Block/Logic/VarSpec.hs | 154 +++++++----- .../test/Test/Pos/Generator/Block/LrcSpec.hs | 70 +++--- infra/Pos/Infra/DHT/Workers.hs | 51 ++-- infra/Pos/Infra/Recovery/Info.hs | 33 +-- infra/Pos/Infra/Slotting/Class.hs | 14 +- infra/Pos/Infra/Slotting/Impl/Simple.hs | 64 ++--- infra/Pos/Infra/Slotting/Impl/Util.hs | 28 ++- infra/Pos/Infra/Slotting/Util.hs | 67 ++++-- infra/Pos/Infra/Util/JsonLog/Events.hs | 36 +-- .../Bench/Pos/Diffusion/BlockDownload.hs | 2 +- lib/src/Pos/DB/DB.hs | 22 +- lib/src/Pos/GState/GState.hs | 10 +- lib/src/Pos/Launcher/Configuration.hs | 9 +- lib/src/Pos/Launcher/Launcher.hs | 23 +- lib/src/Pos/Launcher/Mode.hs | 4 +- lib/src/Pos/Launcher/Resource.hs | 55 +++-- lib/src/Pos/Launcher/Runner.hs | 27 +-- lib/src/Pos/Launcher/Scenario.hs | 15 +- lib/src/Pos/Logic/Full.hs | 138 +++++++---- lib/src/Pos/Recovery/Instance.hs | 11 +- lib/src/Pos/WorkMode.hs | 6 +- lib/src/Pos/Worker.hs | 12 +- lib/src/Test/Pos/Configuration.hs | 11 +- .../Test/Pos/Block/Identity/SafeCopySpec.hs | 3 +- lib/test/Test/Pos/Cbor/CborSpec.hs | 2 +- lib/test/Test/Pos/Diffusion/BlockSpec.hs | 3 +- lib/test/Test/Pos/Genesis/CanonicalSpec.hs | 3 +- lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs | 2 +- lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs | 29 +-- lib/test/Test/Pos/Ssc/Toss/PureSpec.hs | 4 +- lib/test/Test/Pos/Ssc/VssCertDataSpec.hs | 17 +- lib/test/Test/Pos/Types/BlockSpec.hs | 29 ++- .../Test/Pos/Types/Identity/SafeCopySpec.hs | 3 +- lib/test/Test/Pos/Update/PollSpec.hs | 24 +- lrc/src/Pos/Lrc/DB/Leaders.hs | 33 ++- lrc/src/Pos/Lrc/Fts.hs | 7 +- lrc/src/Pos/Lrc/Genesis.hs | 13 +- lrc/test/Test/Pos/Lrc/FtsSpec.hs | 35 +-- node/Main.hs | 11 +- node/cardano-sl-node.cabal | 1 + pkgs/default.nix | 13 + ssc/Pos/Arbitrary/Ssc.hs | 25 +- ssc/Pos/Ssc/Base.hs | 96 +++----- ssc/Pos/Ssc/Functions.hs | 39 +-- ssc/Pos/Ssc/Logic/Local.hs | 100 ++++---- ssc/Pos/Ssc/Logic/VAR.hs | 65 ++--- ssc/Pos/Ssc/State.hs | 15 +- ssc/Pos/Ssc/State/Global.hs | 15 +- ssc/Pos/Ssc/State/Local.hs | 31 +-- ssc/Pos/Ssc/Toss/Base.hs | 54 +++-- ssc/Pos/Ssc/Toss/Class.hs | 11 +- ssc/Pos/Ssc/Toss/Logic.hs | 87 ++++--- ssc/Pos/Ssc/Toss/Pure.hs | 14 +- ssc/Pos/Ssc/Toss/Trans.hs | 2 +- ssc/Pos/Ssc/Toss/Types.hs | 24 +- ssc/Pos/Ssc/Worker.hs | 182 ++++++++------ tools/src/blockchain-analyser/Main.hs | 2 +- tools/src/dbgen/Main.hs | 17 +- tools/src/keygen/Main.hs | 22 +- tools/src/launcher/Main.hs | 2 +- txp/src/Pos/Txp/Logic/Local.hs | 71 +++--- txp/src/Pos/Txp/MemState/Class.hs | 6 +- txp/src/Pos/Txp/Network/Listeners.hs | 25 +- txp/test/Test/Pos/Txp/Toil/UtxoSpec.hs | 4 +- update/src/Pos/Update/Context.hs | 14 +- update/src/Pos/Update/DB.hs | 12 +- update/src/Pos/Update/Logic/Global.hs | 38 ++- update/src/Pos/Update/Logic/Local.hs | 32 +-- update/src/Pos/Update/MemState/Types.hs | 12 +- update/src/Pos/Update/Network/Listeners.hs | 17 +- update/src/Pos/Update/Poll/Logic/Apply.hs | 49 ++-- update/src/Pos/Update/Poll/Logic/Base.hs | 16 +- update/src/Pos/Update/Poll/Logic/Softfork.hs | 30 ++- update/src/Pos/Update/Worker.hs | 25 +- update/test/Test/Pos/Update/Arbitrary/Poll.hs | 13 +- wallet-new/cardano-sl-wallet-new.cabal | 3 + wallet-new/server/Main.hs | 34 +-- .../src/Cardano/Wallet/API/V0/Handlers.hs | 6 +- .../Cardano/Wallet/API/V1/LegacyHandlers.hs | 8 +- .../API/V1/LegacyHandlers/Transactions.hs | 19 +- .../Wallet/API/V1/LegacyHandlers/Wallets.hs | 17 +- wallet-new/src/Cardano/Wallet/Kernel/Mode.hs | 13 +- wallet-new/src/Cardano/Wallet/LegacyServer.hs | 13 +- .../src/Cardano/Wallet/Server/Plugins.hs | 22 +- wallet-new/test/DevelopmentSpec.hs | 2 +- wallet-new/test/WalletHandlersSpec.hs | 39 ++- wallet-new/test/unit/Test/Spec/Submission.hs | 63 ++--- wallet-new/test/unit/UTxO/Context.hs | 4 +- wallet-new/test/unit/UTxO/Interpreter.hs | 5 +- wallet-new/test/unit/UTxO/Translate.hs | 15 +- wallet-new/test/unit/UTxO/Verify.hs | 15 +- wallet/cardano-sl-wallet.cabal | 1 + wallet/src/Pos/Wallet/Redirect.hs | 25 +- wallet/src/Pos/Wallet/Web/Methods/Misc.hs | 12 +- wallet/src/Pos/Wallet/Web/Methods/Payment.hs | 51 ++-- wallet/src/Pos/Wallet/Web/Methods/Redeem.hs | 26 +- wallet/src/Pos/Wallet/Web/Methods/Txp.hs | 6 +- wallet/src/Pos/Wallet/Web/Mode.hs | 8 +- .../src/Pos/Wallet/Web/Pending/Functions.hs | 27 ++- .../src/Pos/Wallet/Web/Pending/Submission.hs | 10 +- wallet/src/Pos/Wallet/Web/Pending/Util.hs | 14 +- wallet/src/Pos/Wallet/Web/Pending/Worker.hs | 72 +++--- wallet/src/Pos/Wallet/Web/Server/Handlers.hs | 31 ++- wallet/src/Pos/Wallet/Web/Server/Launcher.hs | 12 +- wallet/src/Pos/Wallet/Web/Server/Runner.hs | 17 +- wallet/src/Pos/Wallet/Web/State/State.hs | 39 +-- .../src/Pos/Wallet/Web/Tracking/BListener.hs | 28 ++- wallet/src/Pos/Wallet/Web/Tracking/Sync.hs | 45 ++-- .../test/Test/Pos/Wallet/Web/AddressSpec.hs | 8 +- .../Web/Methods/BackupDefaultAddressesSpec.hs | 2 +- .../Test/Pos/Wallet/Web/Methods/LogicSpec.hs | 2 +- .../Pos/Wallet/Web/Methods/PaymentSpec.hs | 8 +- wallet/test/Test/Pos/Wallet/Web/Mode.hs | 16 +- .../Test/Pos/Wallet/Web/Tracking/SyncSpec.hs | 13 +- wallet/test/Test/Pos/Wallet/Web/Util.hs | 5 +- 192 files changed, 3553 insertions(+), 2886 deletions(-) delete mode 100644 core/src/Pos/Core/Configuration/Protocol.hs create mode 100644 core/test/Test/Pos/Core/Dummy.hs diff --git a/auxx/Main.hs b/auxx/Main.hs index d8d72f05ed8..1db4b2ce745 100644 --- a/auxx/Main.hs +++ b/auxx/Main.hs @@ -14,7 +14,8 @@ import System.Wlog (LoggerName, logInfo) import qualified Pos.Client.CLI as CLI import Pos.Context (NodeContext (..)) -import Pos.Core (ConfigurationError, epochSlots) +import Pos.Core (ConfigurationError, ProtocolConstants, + pcBlkSecurityParam) import Pos.Crypto (ProtocolMagic) import Pos.DB.DB (initNodeDBs) import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion) @@ -72,64 +73,88 @@ correctNodeParams AuxxOptions {..} np = do , ncTcpAddr = TCP.Unaddressable } -runNodeWithSinglePlugin :: - (HasConfigurations, HasCompileInfo) +runNodeWithSinglePlugin + :: (HasConfigurations, HasCompileInfo) => ProtocolMagic + -> ProtocolConstants -> NodeResources EmptyMempoolExt -> (Diffusion AuxxMode -> AuxxMode ()) - -> Diffusion AuxxMode -> AuxxMode () -runNodeWithSinglePlugin pm nr plugin = - runNode pm nr [plugin] + -> Diffusion AuxxMode + -> AuxxMode () +runNodeWithSinglePlugin pm pc nr plugin = + runNode pm pc nr [plugin] -action :: HasCompileInfo => AuxxOptions -> Either WithCommandAction Text -> Production () +action + :: HasCompileInfo + => AuxxOptions + -> Either WithCommandAction Text + -> Production () action opts@AuxxOptions {..} command = do let pa = either printAction (const putText) command case aoStartMode of - Automatic - -> - handle @_ @ConfigurationException (\_ -> runWithoutNode pa) - . handle @_ @ConfigurationError (\_ -> runWithoutNode pa) - $ withConfigurations Nothing conf (runWithConfig pa) - Light - -> runWithoutNode pa - _ -> withConfigurations Nothing conf (runWithConfig pa) - + Automatic -> + handle @_ @ConfigurationException (\_ -> runWithoutNode pa) + . handle @_ @ConfigurationError (\_ -> runWithoutNode pa) + $ withConfigurations Nothing conf (runWithConfig pa) + Light -> runWithoutNode pa + _ -> withConfigurations Nothing conf (runWithConfig pa) where runWithoutNode :: PrintAction Production -> Production () - runWithoutNode printAction = printAction "Mode: light" >> rawExec Nothing Nothing opts Nothing command + runWithoutNode printAction = + printAction "Mode: light" + >> rawExec Nothing Nothing Nothing opts Nothing command - runWithConfig :: HasConfigurations => PrintAction Production -> NtpConfiguration -> ProtocolMagic -> Production () - runWithConfig printAction ntpConfig pm = do + runWithConfig + :: HasConfigurations + => PrintAction Production + -> NtpConfiguration + -> ProtocolMagic + -> ProtocolConstants + -> Production () + runWithConfig printAction ntpConfig pm pc = do printAction "Mode: with-config" CLI.printInfoOnStart aoCommonNodeArgs ntpConfig (nodeParams, tempDbUsed) <- correctNodeParams opts =<< CLI.getNodeParams loggerName cArgs nArgs - let toRealMode :: AuxxMode a -> RealMode EmptyMempoolExt a + let + toRealMode :: AuxxMode a -> RealMode EmptyMempoolExt a toRealMode auxxAction = do realModeContext <- ask - let auxxContext = - AuxxContext + let auxxContext = AuxxContext { acRealModeContext = realModeContext - , acTempDbUsed = tempDbUsed } + , acTempDbUsed = tempDbUsed + } lift $ runReaderT auxxAction auxxContext vssSK = fromMaybe (error "no user secret given") (npUserSecret nodeParams ^. usVss) - sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig nodeParams) + sscParams = + CLI.gtSscParams cArgs vssSK (npBehaviorConfig nodeParams) - bracketNodeResources nodeParams sscParams (txpGlobalSettings pm) (initNodeDBs pm epochSlots) $ \nr -> Production $ - let NodeContext {..} = nrContext nr - modifier = if aoStartMode == WithNode - then runNodeWithSinglePlugin pm nr - else identity - auxxModeAction = modifier (auxxPlugin pm opts command) - in runRealMode pm nr $ \diffusion -> - toRealMode (auxxModeAction (hoistDiffusion realModeToAuxx toRealMode diffusion)) + bracketNodeResources (pcBlkSecurityParam pc) + nodeParams + sscParams + (txpGlobalSettings pm) + (initNodeDBs pm pc) + $ \nr -> + Production + $ let + NodeContext {..} = nrContext nr + modifier = if aoStartMode == WithNode + then runNodeWithSinglePlugin pm pc nr + else identity + auxxModeAction = + modifier (auxxPlugin pm pc opts command) + in + runRealMode pm pc nr $ \diffusion -> + toRealMode $ auxxModeAction $ hoistDiffusion + realModeToAuxx + toRealMode + diffusion cArgs@CLI.CommonNodeArgs {..} = aoCommonNodeArgs conf = CLI.configurationOptions (CLI.commonArgs cArgs) - nArgs = - CLI.NodeArgs {behaviorConfigPath = Nothing} + nArgs = CLI.NodeArgs {behaviorConfigPath = Nothing} main :: IO () main = withCompileInfo $ do diff --git a/auxx/src/Command/BlockGen.hs b/auxx/src/Command/BlockGen.hs index a0b2a9b7946..7ff6e8f0736 100644 --- a/auxx/src/Command/BlockGen.hs +++ b/auxx/src/Command/BlockGen.hs @@ -13,7 +13,7 @@ import System.Wlog (logInfo) import Pos.AllSecrets (mkAllSecretsSimple) import Pos.Client.KeyStorage (getSecretKeysPlain) -import Pos.Core (gdBootStakeholders, genesisData) +import Pos.Core (ProtocolConstants, gdBootStakeholders, genesisData) import Pos.Crypto (ProtocolMagic, encToSecret) import Pos.Generator.Block (BlockGenParams (..), genBlocks, tgpTxCountRange) @@ -25,26 +25,32 @@ import Pos.Util.CompileInfo (withCompileInfo) import Lang.Value (GenBlocksParams (..)) import Mode (MonadAuxxMode) - -generateBlocks :: MonadAuxxMode m => ProtocolMagic -> GenBlocksParams -> m () -generateBlocks pm GenBlocksParams{..} = withStateLock HighPriority ApplyBlock $ \_ -> do - seed <- liftIO $ maybe randomIO pure bgoSeed - logInfo $ "Generating with seed " <> show seed - - allSecrets <- mkAllSecretsSimple . map encToSecret <$> getSecretKeysPlain - - let bgenParams = - BlockGenParams - { _bgpSecrets = allSecrets - , _bgpGenStakeholders = gdBootStakeholders genesisData - , _bgpBlockCount = fromIntegral bgoBlockN - -- tx generation is disalbed for now - , _bgpTxGenParams = def & tgpTxCountRange .~ (0,0) - , _bgpInplaceDB = True - , _bgpSkipNoKey = True +generateBlocks + :: MonadAuxxMode m + => ProtocolMagic + -> ProtocolConstants + -> GenBlocksParams + -> m () +generateBlocks pm pc GenBlocksParams {..} = + withStateLock HighPriority ApplyBlock $ \_ -> do + seed <- liftIO $ maybe randomIO pure bgoSeed + logInfo $ "Generating with seed " <> show seed + + allSecrets <- + mkAllSecretsSimple . map encToSecret <$> getSecretKeysPlain + + let bgenParams = BlockGenParams + { _bgpSecrets = allSecrets + , _bgpGenStakeholders = gdBootStakeholders genesisData + , _bgpBlockCount = fromIntegral bgoBlockN + -- tx generation is disabled for now + , _bgpTxGenParams = def & tgpTxCountRange .~ (0, 0) + , _bgpInplaceDB = True + , _bgpSkipNoKey = True , _bgpTxpGlobalSettings = txpGlobalSettings pm } - withCompileInfo $ evalRandT (genBlocks pm bgenParams (const ())) (mkStdGen seed) - -- We print it twice because there can be a ton of logs and - -- you don't notice the first message. - logInfo $ "Generated with seed " <> show seed + withCompileInfo $ evalRandT (genBlocks pm pc bgenParams (const ())) + (mkStdGen seed) + -- We print it twice because there can be a ton of logs and + -- you don't notice the first message. + logInfo $ "Generated with seed " <> show seed diff --git a/auxx/src/Command/Proc.hs b/auxx/src/Command/Proc.hs index fc19365dd6e..076d39dda1b 100644 --- a/auxx/src/Command/Proc.hs +++ b/auxx/src/Command/Proc.hs @@ -18,9 +18,9 @@ import qualified Text.JSON.Canonical as CanonicalJSON import Pos.Client.KeyStorage (addSecretKey, getSecretKeysPlain) import Pos.Client.Txp.Balances (getBalance) -import Pos.Core (AddrStakeDistribution (..), Address, - HeavyDlgIndex (..), SoftwareVersion (..), StakeholderId, - addressHash, mkMultiKeyDistr, unsafeGetCoin) +import Pos.Core (AddrStakeDistribution (..), HeavyDlgIndex (..), + ProtocolConstants, SoftwareVersion (..), StakeholderId, + addressHash, mkMultiKeyDistr, pcEpochSlots, unsafeGetCoin) import Pos.Core.Common (AddrAttributes (..), AddrSpendingData (..), makeAddress) import Pos.Core.Configuration (genesisSecretKeys) @@ -59,14 +59,16 @@ import Mode (MonadAuxxMode, deriveHDAddressAuxx, makePubKeyAddressAuxx) import Repl (PrintAction) -createCommandProcs :: - forall m. (MonadIO m, CanLog m, HasLoggerName m) +createCommandProcs + :: forall m + . (MonadIO m, CanLog m, HasLoggerName m) => Maybe ProtocolMagic + -> Maybe ProtocolConstants -> Maybe (Dict (MonadAuxxMode m)) -> PrintAction m -> Maybe (Diffusion m) -> [CommandProc m] -createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \commands -> [ +createCommandProcs mpm mpc hasAuxxMode printAction mDiffusion = rights . fix $ \commands -> [ return CommandProc { cpName = "L" @@ -97,6 +99,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm }, let name = "addr" in + needsProtocolConstants name >>= \pc -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name @@ -108,7 +111,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm , cpExec = \(pk', mDistr) -> do pk <- toLeft pk' addr <- case mDistr of - Nothing -> makePubKeyAddressAuxx pk + Nothing -> makePubKeyAddressAuxx (pcEpochSlots pc) pk Just distr -> return $ makeAddress (PubKeyASD pk) (AddrAttributes Nothing distr) return $ ValueAddress addr @@ -118,6 +121,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm }, let name = "addr-hd" in + needsProtocolConstants name >>= \pc -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name @@ -128,7 +132,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm sk <- evaluateWHNF (sks !! i) -- WHNF is sufficient to force possible errors -- from using (!!). I'd use NF but there's no -- NFData instance for secret keys. - addrHD <- deriveHDAddressAuxx sk + addrHD <- deriveHDAddressAuxx (pcEpochSlots pc) sk return $ ValueAddress addrHD , cpHelp = "address of the HD wallet for the specified public key" }, @@ -185,13 +189,16 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm return . procConst "false" $ ValueBool False, let name = "balance" in + needsProtocolConstants name >>= \pc -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name , cpArgumentPrepare = identity , cpArgumentConsumer = getArg (tyAddress `tyEither` tyPublicKey `tyEither` tyInt) "addr" , cpExec = \addr' -> do - addr <- toLeft addr' + addr <- + either return (makePubKeyAddressAuxx $ pcEpochSlots pc) <=< + traverse (either return getPublicKeyFromIndex) $ addr' balance <- getBalance addr return $ ValueNumber (fromIntegral . unsafeGetCoin $ balance) , cpHelp = "check the amount of coins on the specified address" @@ -209,6 +216,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm let name = "send-to-all-genesis" in needsProtocolMagic name >>= \pm -> + needsProtocolConstants name >>= \pc -> needsDiffusion name >>= \diffusion -> needsAuxxMode name >>= \Dict -> return CommandProc @@ -222,7 +230,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm stagpTpsSentFile <- getArg tyFilePath "file" return Tx.SendToAllGenesisParams{..} , cpExec = \stagp -> do - Tx.sendToAllGenesis pm diffusion stagp + Tx.sendToAllGenesis pm (pcEpochSlots pc) diffusion stagp return ValueUnit , cpHelp = "create and send transactions from all genesis addresses \ \ for seconds, in ms. is the \ @@ -244,6 +252,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm let name = "send" in needsProtocolMagic name >>= \pm -> + needsProtocolConstants name >>= \pc -> needsDiffusion name >>= \diffusion -> needsAuxxMode name >>= \Dict -> return CommandProc @@ -253,7 +262,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm (,) <$> getArg tyInt "i" <*> getArgSome tyTxOut "out" , cpExec = \(i, outputs) -> do - Tx.send pm diffusion i outputs + Tx.send pm (pcEpochSlots pc) diffusion i outputs return ValueUnit , cpHelp = "send from #i to specified transaction outputs \ \ (use 'tx-out' to build them)" @@ -400,6 +409,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm let name = "generate-blocks" in needsProtocolMagic name >>= \pm -> + needsProtocolConstants name >>= \pc -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name @@ -409,7 +419,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm bgoSeed <- getArgOpt tyInt "seed" return GenBlocksParams{..} , cpExec = \params -> do - generateBlocks pm params + generateBlocks pm pc params return ValueUnit , cpHelp = "generate blocks" }, @@ -454,6 +464,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm let name = "rollback" in needsProtocolMagic name >>= \pm -> + needsProtocolConstants name >>= \pc -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name @@ -463,24 +474,26 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm rpDumpPath <- getArg tyFilePath "dump-file" pure RollbackParams{..} , cpExec = \RollbackParams{..} -> do - Rollback.rollbackAndDump pm rpNum rpDumpPath + Rollback.rollbackAndDump pm pc rpNum rpDumpPath return ValueUnit , cpHelp = "" }, let name = "listaddr" in + needsProtocolConstants name >>= \pc -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name , cpArgumentPrepare = identity , cpArgumentConsumer = do pure () , cpExec = \() -> do + let epochSlots = pcEpochSlots pc sks <- getSecretKeysPlain printAction "Available addresses:" for_ (zip [0 :: Int ..] sks) $ \(i, sk) -> do let pk = encToPublic sk - addr <- makePubKeyAddressAuxx pk - addrHD <- deriveHDAddressAuxx sk + addr <- makePubKeyAddressAuxx epochSlots pk + addrHD <- deriveHDAddressAuxx epochSlots sk printAction $ sformat (" #"%int%": addr: "%build%"\n"% " pk: "%fullPublicKeyF%"\n"% @@ -489,7 +502,7 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm i addr pk (addressHash pk) addrHD walletMB <- (^. usWallet) <$> (view userSecret >>= atomically . readTVar) whenJust walletMB $ \wallet -> do - addrHD <- deriveHDAddressAuxx (_wusRootKey wallet) + addrHD <- deriveHDAddressAuxx epochSlots (_wusRootKey wallet) printAction $ sformat (" Wallet address:\n"% " HD addr: "%build) @@ -517,6 +530,9 @@ createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \comm needsProtocolMagic :: Name -> Either UnavailableCommand ProtocolMagic needsProtocolMagic name = maybe (Left $ UnavailableCommand name "ProtocolMagic is not available") Right mpm + needsProtocolConstants :: Name -> Either UnavailableCommand ProtocolConstants + needsProtocolConstants name = + maybe (Left $ UnavailableCommand name "ProtocolConstants are not available") Right mpc procConst :: Applicative m => Name -> Value -> CommandProc m procConst name value = @@ -540,9 +556,6 @@ instance MonadAuxxMode m => ToLeft m PublicKey Int where instance MonadAuxxMode m => ToLeft m StakeholderId PublicKey where toLeft = return . either identity addressHash -instance MonadAuxxMode m => ToLeft m Address PublicKey where - toLeft = either return makePubKeyAddressAuxx - getPublicKeyFromIndex :: MonadAuxxMode m => Int -> m PublicKey getPublicKeyFromIndex i = do sks <- getSecretKeysPlain diff --git a/auxx/src/Command/Rollback.hs b/auxx/src/Command/Rollback.hs index 2b3b186fb5a..be1b86be536 100644 --- a/auxx/src/Command/Rollback.hs +++ b/auxx/src/Command/Rollback.hs @@ -17,7 +17,7 @@ import Pos.Block.Logic (BypassSecurityCheck (..), rollbackBlocksUnsafe) import Pos.Block.Slog (ShouldCallBListener (..)) import Pos.Block.Types (Blund) -import Pos.Core (difficultyL, epochIndexL) +import Pos.Core (ProtocolConstants, difficultyL, epochIndexL) import Pos.Core.Block (mainBlockTxPayload) import Pos.Core.Chrono (NewestFirst, _NewestFirst) import Pos.Core.Txp (TxAux) @@ -35,41 +35,49 @@ import Mode (MonadAuxxMode) rollbackAndDump :: MonadAuxxMode m => ProtocolMagic + -> ProtocolConstants -> Word -> FilePath -> m () -rollbackAndDump pm numToRollback outFile = withStateLock HighPriority ApplyBlockWithRollback $ \_ -> do - printTipDifficulty - blundsMaybeEmpty <- modifyBlunds <$> - DB.loadBlundsFromTipByDepth (fromIntegral numToRollback) - logInfo $ sformat ("Loaded "%int%" blunds") (length blundsMaybeEmpty) - case _Wrapped nonEmpty blundsMaybeEmpty of - Nothing -> pass - Just blunds -> do - let extractTxs :: Blund -> [TxAux] - extractTxs (Left _, _) = [] - extractTxs (Right mainBlock, _) = - flattenTxPayload $ mainBlock ^. mainBlockTxPayload - let allTxs :: [TxAux] - allTxs = concatMap extractTxs blunds - liftIO $ BSL.writeFile outFile (encode allTxs) - logInfo $ sformat ("Dumped "%int%" transactions to "%string) - (length allTxs) (outFile) - rollbackBlocksUnsafe pm (BypassSecurityCheck True) (ShouldCallBListener True) blunds - logInfo $ sformat ("Rolled back "%int%" blocks") (length blunds) - printTipDifficulty +rollbackAndDump pm pc numToRollback outFile = + withStateLock HighPriority ApplyBlockWithRollback $ \_ -> do + printTipDifficulty + blundsMaybeEmpty <- modifyBlunds + <$> DB.loadBlundsFromTipByDepth (fromIntegral numToRollback) + logInfo $ sformat ("Loaded " % int % " blunds") + (length blundsMaybeEmpty) + case _Wrapped nonEmpty blundsMaybeEmpty of + Nothing -> pass + Just blunds -> do + let extractTxs :: Blund -> [TxAux] + extractTxs (Left _, _) = [] + extractTxs (Right mainBlock, _) = + flattenTxPayload $ mainBlock ^. mainBlockTxPayload + let allTxs :: [TxAux] + allTxs = concatMap extractTxs blunds + liftIO $ BSL.writeFile outFile (encode allTxs) + logInfo $ sformat + ("Dumped " % int % " transactions to " % string) + (length allTxs) + (outFile) + rollbackBlocksUnsafe pm + pc + (BypassSecurityCheck True) + (ShouldCallBListener True) + blunds + logInfo $ sformat ("Rolled back " % int % " blocks") + (length blunds) + printTipDifficulty where - -- It's illegal to rollback 0-th genesis block. We also may load - -- more blunds than necessary, because genesis blocks don't - -- contribute to depth counter. + -- It's illegal to rollback 0-th genesis block. We also may load more blunds + -- than necessary, because genesis blocks don't contribute to depth counter. modifyBlunds :: NewestFirst [] Blund -> NewestFirst [] Blund modifyBlunds = over _NewestFirst (genericTake numToRollback . skip0thGenesis) skip0thGenesis = filter (not . is0thGenesis) is0thGenesis :: Blund -> Bool - is0thGenesis (Left genBlock, _) - | genBlock ^. epochIndexL == 0 = True - is0thGenesis _ = False + is0thGenesis (Left genBlock, _) | genBlock ^. epochIndexL == 0 = True + is0thGenesis _ = False printTipDifficulty = do tipDifficulty <- view difficultyL <$> DB.getTipHeader - logInfo $ sformat ("Our tip's difficulty is "%build) tipDifficulty + logInfo $ sformat ("Our tip's difficulty is " % build) tipDifficulty diff --git a/auxx/src/Command/Tx.hs b/auxx/src/Command/Tx.hs index eb6db3af8e6..84fc0c653ad 100644 --- a/auxx/src/Command/Tx.hs +++ b/auxx/src/Command/Tx.hs @@ -40,7 +40,7 @@ import Pos.Client.Txp.Balances (getOwnUtxoForPk) import Pos.Client.Txp.Network (prepareMTx, submitTxRaw) import Pos.Client.Txp.Util (createTx) import Pos.Core (BlockVersionData (bvdSlotDuration), - IsBootstrapEraAddr (..), Timestamp (..), + IsBootstrapEraAddr (..), SlotCount, Timestamp (..), deriveFirstHDAddress, makePubKeyAddress, mkCoin) import Pos.Core.Configuration (genesisBlockVersionData, genesisSecretKeys) @@ -84,12 +84,14 @@ addTxSubmit = pure (TxCount (submitted + 1) sending, ())) sendToAllGenesis - :: forall m. MonadAuxxMode m + :: forall m + . MonadAuxxMode m => ProtocolMagic + -> SlotCount -> Diffusion m -> SendToAllGenesisParams -> m () -sendToAllGenesis pm diffusion (SendToAllGenesisParams genesisTxsPerThread txsPerThread conc delay_ tpsSentFile) = do +sendToAllGenesis pm epochSlots diffusion (SendToAllGenesisParams genesisTxsPerThread txsPerThread conc delay_ tpsSentFile) = do let genesisSlotDuration = fromIntegral (toMicroseconds $ bvdSlotDuration genesisBlockVersionData) `div` 1000000 :: Int keysToSend = fromMaybe (error "Genesis secret keys are unknown") genesisSecretKeys tpsMVar <- newSharedAtomic $ TxCount 0 conc @@ -114,14 +116,14 @@ sendToAllGenesis pm diffusion (SendToAllGenesisParams genesisTxsPerThread txsPer let signer = fakeSigner secretKey publicKey = toPublic secretKey -- construct transaction output - outAddr <- makePubKeyAddressAuxx publicKey + outAddr <- makePubKeyAddressAuxx epochSlots publicKey let txOut1 = TxOut { txOutAddress = outAddr, txOutValue = mkCoin 1 } txOuts = TxOutAux txOut1 :| [] utxo <- getOwnUtxoForPk $ safeToPublic signer - etx <- createTx pm mempty utxo signer txOuts publicKey + etx <- createTx pm epochSlots mempty utxo signer txOuts publicKey case etx of Left err -> logError (sformat ("Error: "%build%" while trying to contruct tx") err) Right (tx, _) -> do @@ -143,7 +145,7 @@ sendToAllGenesis pm diffusion (SendToAllGenesisParams genesisTxsPerThread txsPer txOuts2 = TxOutAux txOut1' :| [] -- It is expected that the output from the previously sent transaction is -- included in the UTxO by the time this transaction will actually be sent. - etx' <- createTx pm mempty utxo' (fakeSigner senderKey) txOuts2 (toPublic senderKey) + etx' <- createTx pm epochSlots mempty utxo' (fakeSigner senderKey) txOuts2 (toPublic senderKey) case etx' of Left err -> logError (sformat ("Error: "%build%" while trying to contruct tx") err) Right (tx', _) -> do @@ -218,36 +220,58 @@ newtype AuxxException = AuxxException Text instance Exception AuxxException send - :: forall m. MonadAuxxMode m + :: forall m + . MonadAuxxMode m => ProtocolMagic + -> SlotCount -> Diffusion m -> Int -> NonEmpty TxOut -> m () -send pm diffusion idx outputs = do +send pm epochSlots diffusion idx outputs = do skey <- takeSecret let curPk = encToPublic skey - let plainAddresses = map (flip makePubKeyAddress curPk . IsBootstrapEraAddr) [False, True] - let (hdAddresses, hdSecrets) = unzip $ map - (\ibea -> fromMaybe (error "send: pass mismatch") $ - deriveFirstHDAddress (IsBootstrapEraAddr ibea) emptyPassphrase skey) [False, True] + let plainAddresses = map + (flip makePubKeyAddress curPk . IsBootstrapEraAddr) + [False, True] + let + (hdAddresses, hdSecrets) = unzip $ map + (\ibea -> + fromMaybe (error "send: pass mismatch") $ deriveFirstHDAddress + (IsBootstrapEraAddr ibea) + emptyPassphrase + skey + ) + [False, True] let allAddresses = hdAddresses ++ plainAddresses - let allSecrets = hdSecrets ++ [skey, skey] - etx <- withSafeSigners allSecrets (pure emptyPassphrase) $ \signers -> runExceptT @AuxxException $ do - let addrSig = HM.fromList $ zip allAddresses signers - let getSigner addr = HM.lookup addr addrSig - -- BE CAREFUL: We create remain address using our pk, wallet doesn't show such addresses - (txAux,_) <- lift $ prepareMTx pm getSigner mempty def (NE.fromList allAddresses) (map TxOutAux outputs) curPk - txAux <$ (ExceptT $ try $ submitTxRaw diffusion txAux) + let allSecrets = hdSecrets ++ [skey, skey] + etx <- withSafeSigners allSecrets (pure emptyPassphrase) $ \signers -> + runExceptT @AuxxException $ do + let addrSig = HM.fromList $ zip allAddresses signers + let getSigner addr = HM.lookup addr addrSig + -- BE CAREFUL: We create remain address using our pk, wallet doesn't + -- show such addresses + (txAux, _) <- lift $ prepareMTx pm + epochSlots + getSigner + mempty + def + (NE.fromList allAddresses) + (map TxOutAux outputs) + curPk + txAux <$ (ExceptT $ try $ submitTxRaw diffusion txAux) case etx of - Left err -> logError $ sformat ("Error: "%stext) (toText $ displayException err) - Right tx -> logInfo $ sformat ("Submitted transaction: "%txaF) tx + Left err -> logError + $ sformat ("Error: " % stext) (toText $ displayException err) + Right tx -> logInfo $ sformat ("Submitted transaction: " % txaF) tx where takeSecret :: m EncryptedSecretKey takeSecret | idx == -1 = do _userSecret <- view userSecret >>= atomically . readTVar - pure $ maybe (error "Unknown wallet address") (^. wusRootKey) (_userSecret ^. usWallet) + pure $ maybe (error "Unknown wallet address") + (^. wusRootKey) + (_userSecret ^. usWallet) | otherwise = (!! idx) <$> getSecretKeysPlain ---------------------------------------------------------------------------- diff --git a/auxx/src/Mode.hs b/auxx/src/Mode.hs index 767833cdc0b..719b90d3692 100644 --- a/auxx/src/Mode.hs +++ b/auxx/src/Mode.hs @@ -41,7 +41,7 @@ import Pos.Client.Txp.History (MonadTxHistory (..), saveTxDefault) import Pos.Context (HasNodeContext (..)) import Pos.Core (Address, HasConfiguration, HasPrimaryKey (..), - IsBootstrapEraAddr (..), deriveFirstHDAddress, + IsBootstrapEraAddr (..), SlotCount, deriveFirstHDAddress, largestPubKeyAddressBoot, largestPubKeyAddressSingleKey, makePubKeyAddress, siEpoch) import Pos.Crypto (EncryptedSecretKey, PublicKey, emptyPassphrase) @@ -161,12 +161,10 @@ instance HasSlogGState AuxxContext where instance HasJsonLogConfig AuxxContext where jsonLogConfig = acRealModeContext_L . jsonLogConfig -instance (HasConfiguration, MonadSlotsData ctx AuxxMode) - => MonadSlots ctx AuxxMode - where - getCurrentSlot = realModeToAuxx getCurrentSlot - getCurrentSlotBlocking = realModeToAuxx getCurrentSlotBlocking - getCurrentSlotInaccurate = realModeToAuxx getCurrentSlotInaccurate +instance MonadSlotsData ctx AuxxMode => MonadSlots ctx AuxxMode where + getCurrentSlot = realModeToAuxx . getCurrentSlot + getCurrentSlotBlocking = realModeToAuxx . getCurrentSlotBlocking + getCurrentSlotInaccurate = realModeToAuxx . getCurrentSlotInaccurate currentTimeSlotting = realModeToAuxx currentTimeSlotting instance {-# OVERLAPPING #-} HasLoggerName AuxxMode where @@ -216,8 +214,8 @@ instance (HasConfigurations, HasCompileInfo) => MonadAddresses AuxxMode where type AddrData AuxxMode = PublicKey getNewAddress = makePubKeyAddressAuxx - getFakeChangeAddress = do - epochIndex <- siEpoch <$> getCurrentSlotInaccurate + getFakeChangeAddress pc = do + epochIndex <- siEpoch <$> getCurrentSlotInaccurate pc gsIsBootstrapEra epochIndex <&> \case False -> largestPubKeyAddressBoot True -> largestPubKeyAddressSingleKey @@ -234,8 +232,9 @@ instance ( HasConfiguration , HasTxpConfiguration ) => MonadTxpLocal AuxxMode where - txpNormalize = withReaderT acRealModeContext . txNormalize - txpProcessTx pm = withReaderT acRealModeContext . txProcessTransaction pm + txpNormalize pm = withReaderT acRealModeContext . txNormalize pm + txpProcessTx pm epochSlots = + withReaderT acRealModeContext . txProcessTransaction pm epochSlots instance (HasConfigurations) => MonadTxpLocal (BlockGenMode EmptyMempoolExt AuxxMode) where @@ -245,22 +244,17 @@ instance (HasConfigurations) => -- | In order to create an 'Address' from a 'PublicKey' we need to -- choose suitable stake distribution. We want to pick it based on -- whether we are currently in bootstrap era. -makePubKeyAddressAuxx :: - MonadAuxxMode m - => PublicKey - -> m Address -makePubKeyAddressAuxx pk = do - epochIndex <- siEpoch <$> getCurrentSlotInaccurate +makePubKeyAddressAuxx :: MonadAuxxMode m => SlotCount -> PublicKey -> m Address +makePubKeyAddressAuxx epochSlots pk = do + epochIndex <- siEpoch <$> getCurrentSlotInaccurate epochSlots ibea <- IsBootstrapEraAddr <$> gsIsBootstrapEra epochIndex pure $ makePubKeyAddress ibea pk -- | Similar to @makePubKeyAddressAuxx@ but create HD address. -deriveHDAddressAuxx :: - MonadAuxxMode m - => EncryptedSecretKey - -> m Address -deriveHDAddressAuxx hdwSk = do - epochIndex <- siEpoch <$> getCurrentSlotInaccurate +deriveHDAddressAuxx + :: MonadAuxxMode m => SlotCount -> EncryptedSecretKey -> m Address +deriveHDAddressAuxx epochSlots hdwSk = do + epochIndex <- siEpoch <$> getCurrentSlotInaccurate epochSlots ibea <- IsBootstrapEraAddr <$> gsIsBootstrapEra epochIndex pure $ fst $ fromMaybe (error "makePubKeyHDAddressAuxx: pass mismatch") $ deriveFirstHDAddress ibea emptyPassphrase hdwSk diff --git a/auxx/src/Plugin.hs b/auxx/src/Plugin.hs index 582d56bd72a..60e63e05233 100644 --- a/auxx/src/Plugin.hs +++ b/auxx/src/Plugin.hs @@ -22,6 +22,7 @@ import Mockable (Delay, Mockable, delay) import System.IO (hFlush, stdout) import System.Wlog (CanLog, HasLoggerName, logInfo) +import Pos.Core (ProtocolConstants) import Pos.Crypto (AHash (..), ProtocolMagic, fullPublicKeyF, hashHexF) import Pos.Infra.Diffusion.Types (Diffusion) @@ -39,50 +40,44 @@ import Repl (PrintAction, WithCommandAction (..)) {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} -auxxPlugin :: - (MonadAuxxMode m, Mockable Delay m) +auxxPlugin + :: (MonadAuxxMode m, Mockable Delay m) => ProtocolMagic + -> ProtocolConstants -> AuxxOptions -> Either WithCommandAction Text -> Diffusion m -> m () -auxxPlugin pm auxxOptions repl = \diffusion -> do +auxxPlugin pm pc auxxOptions repl = \diffusion -> do logInfo $ sformat ("Length of genesis utxo: " %int) (length $ unGenesisUtxo genesisUtxo) - rawExec (Just pm) (Just Dict) auxxOptions (Just diffusion) repl - -rawExec :: - ( MonadIO m - , MonadCatch m - , CanLog m - , HasLoggerName m - , Mockable Delay m - ) + rawExec (Just pm) (Just pc) (Just Dict) auxxOptions (Just diffusion) repl + +rawExec + :: (MonadIO m, MonadCatch m, CanLog m, HasLoggerName m, Mockable Delay m) => Maybe ProtocolMagic + -> Maybe ProtocolConstants -> Maybe (Dict (MonadAuxxMode m)) -> AuxxOptions -> Maybe (Diffusion m) -> Either WithCommandAction Text -> m () -rawExec pm mHasAuxxMode AuxxOptions{..} mDiffusion = \case +rawExec pm pc mHasAuxxMode AuxxOptions{..} mDiffusion = \case Left WithCommandAction{..} -> do printAction "... the auxx plugin is ready" - forever $ withCommand $ runCmd pm mHasAuxxMode mDiffusion printAction - Right cmd -> runWalletCmd pm mHasAuxxMode mDiffusion cmd - -runWalletCmd :: - ( MonadIO m - , CanLog m - , HasLoggerName m - , Mockable Delay m - ) + forever $ withCommand $ runCmd pm pc mHasAuxxMode mDiffusion printAction + Right cmd -> runWalletCmd pm pc mHasAuxxMode mDiffusion cmd + +runWalletCmd + :: (MonadIO m, CanLog m, HasLoggerName m, Mockable Delay m) => Maybe ProtocolMagic + -> Maybe ProtocolConstants -> Maybe (Dict (MonadAuxxMode m)) -> Maybe (Diffusion m) -> Text -> m () -runWalletCmd pm mHasAuxxMode mDiffusion line = do - runCmd pm mHasAuxxMode mDiffusion printAction line +runWalletCmd pm pc mHasAuxxMode mDiffusion line = do + runCmd pm pc mHasAuxxMode mDiffusion printAction line printAction "Command execution finished" printAction " " -- for exit by SIGPIPE liftIO $ hFlush stdout @@ -93,19 +88,17 @@ runWalletCmd pm mHasAuxxMode mDiffusion line = do where printAction = putText -runCmd :: - ( MonadIO m - , CanLog m - , HasLoggerName m - ) +runCmd + :: (MonadIO m, CanLog m, HasLoggerName m) => Maybe ProtocolMagic + -> Maybe ProtocolConstants -> Maybe (Dict (MonadAuxxMode m)) -> Maybe (Diffusion m) -> PrintAction m -> Text -> m () -runCmd pm mHasAuxxMode mDiffusion printAction line = do - let commandProcs = createCommandProcs pm mHasAuxxMode printAction mDiffusion +runCmd pm pc mHasAuxxMode mDiffusion printAction line = do + let commandProcs = createCommandProcs pm pc mHasAuxxMode printAction mDiffusion parse = withExceptT Lang.ppParseError . ExceptT . return . Lang.parse resolveCommandProcs = withExceptT Lang.ppResolveErrors . ExceptT . return . diff --git a/block/bench/Block.hs b/block/bench/Block.hs index 3716e074ed5..a346e97ef45 100644 --- a/block/bench/Block.hs +++ b/block/bench/Block.hs @@ -37,13 +37,6 @@ import Test.Pos.Block.Arbitrary.Generate (generateMainBlock) pm :: ProtocolMagic pm = ProtocolMagic 0 -pc :: ProtocolConstants -pc = ProtocolConstants - { pcK = 7 - , pcVssMaxTTL = maxBound - , pcVssMinTTL = minBound - } - -- | A test subject: a MainBlock, and its various components, each paired with -- its serialization. data TestSubject = TestSubject @@ -101,13 +94,12 @@ withSerialized a = (a, serialize a) -- | Make a TestSubject using a seed for a PRNG and size. testSubject - :: ( ) - => Int -- ^ Seed + :: Int -- ^ Seed -> Int -- ^ Size -> TestSubject testSubject seed size = let block :: MainBlock - block = generateMainBlock pm pc seed size + block = generateMainBlock pm seed size tsBlock = withSerialized block tsHeader = withSerialized (_gbHeader $ block) diff --git a/block/src/Pos/Block/BHelpers.hs b/block/src/Pos/Block/BHelpers.hs index a194d574418..2c3a8c21d3d 100644 --- a/block/src/Pos/Block/BHelpers.hs +++ b/block/src/Pos/Block/BHelpers.hs @@ -21,6 +21,7 @@ import Universum import Control.Monad.Except (MonadError (throwError)) import Pos.Binary.Class (Bi) +import Pos.Core (ProtocolConstants) import Pos.Core.Block (Block, GenesisBlockchain, MainBlockchain, MainConsensusData (..), MainToSign (..)) import Pos.Core.Block.Blockchain (Blockchain (..), GenericBlock (..), @@ -28,7 +29,6 @@ import Pos.Core.Block.Blockchain (Blockchain (..), GenericBlock (..), import Pos.Core.Block.Main (MainBody (..), MainExtraHeaderData (..), MainProof, mainBlockEBDataProof) import Pos.Core.Block.Union (BlockHeader (..), BlockSignature (..)) -import Pos.Core.Configuration (HasProtocolConstants) import Pos.Core.Delegation (LightDlgIndices (..), checkDlgPayload) import Pos.Core.Slotting (SlotId (..)) import Pos.Core.Ssc (checkSscPayload) @@ -51,13 +51,12 @@ verifyBlockHeader pm (BlockHeaderMain bhm) = verifyMainBlockHeader pm bhm -- | Verify a Block in isolation. verifyBlock - :: ( MonadError Text m - , HasProtocolConstants - ) + :: MonadError Text m => ProtocolMagic + -> ProtocolConstants -> Block -> m () -verifyBlock pm = either verifyGenesisBlock (verifyMainBlock pm) +verifyBlock pm pc = either verifyGenesisBlock (verifyMainBlock pm pc) -- | To verify a genesis block we only have to check the body proof. verifyGenesisBlock @@ -71,12 +70,12 @@ verifyMainBlock :: ( MonadError Text m , Bi BlockHeader , Bi MainProof - , HasProtocolConstants ) => ProtocolMagic + -> ProtocolConstants -> GenericBlock MainBlockchain -> m () -verifyMainBlock pm block@UnsafeGenericBlock {..} = do +verifyMainBlock pm pc block@UnsafeGenericBlock {..} = do verifyMainBlockHeader pm _gbHeader verifyMainBody pm _gbBody -- No need to verify the main extra body data. It's an 'Attributes ()' @@ -93,6 +92,7 @@ verifyMainBlock pm block@UnsafeGenericBlock {..} = do either (throwError . pretty) pure $ verifySscPayload pm + pc (Right (Some _gbHeader)) (_mbSscPayload _gbBody) diff --git a/block/src/Pos/Block/BListener.hs b/block/src/Pos/Block/BListener.hs index caee0aff838..b1e897219e1 100644 --- a/block/src/Pos/Block/BListener.hs +++ b/block/src/Pos/Block/BListener.hs @@ -16,6 +16,7 @@ import Control.Monad.Trans (MonadTrans (..)) import Mockable (SharedAtomicT) import Pos.Block.Types (Blund) +import Pos.Core (ProtocolConstants) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.DB.BatchOp (SomeBatchOp) @@ -26,7 +27,7 @@ class Monad m => MonadBListener m where onApplyBlocks :: OldestFirst NE Blund -> m SomeBatchOp -- Callback will be called before changing of GStateDB. -- Callback action will be performed under block lock. - onRollbackBlocks :: NewestFirst NE Blund -> m SomeBatchOp + onRollbackBlocks :: ProtocolConstants -> NewestFirst NE Blund -> m SomeBatchOp instance {-# OVERLAPPABLE #-} ( MonadBListener m, Monad m, MonadTrans t, Monad (t m) @@ -34,7 +35,7 @@ instance {-# OVERLAPPABLE #-} MonadBListener (t m) where onApplyBlocks = lift . onApplyBlocks - onRollbackBlocks = lift . onRollbackBlocks + onRollbackBlocks pc = lift . onRollbackBlocks pc onApplyBlocksStub :: Monad m diff --git a/block/src/Pos/Block/Logic/Creation.hs b/block/src/Pos/Block/Logic/Creation.hs index 0e2ce6cd747..b5b5b77cd7b 100644 --- a/block/src/Pos/Block/Logic/Creation.hs +++ b/block/src/Pos/Block/Logic/Creation.hs @@ -31,10 +31,11 @@ import Pos.Block.Logic.Util (calcChainQualityM) import Pos.Block.Logic.VAR (verifyBlocksPrefix) import Pos.Block.Lrc (LrcModeFull, lrcSingleShot) import Pos.Block.Slog (HasSlogGState (..), ShouldCallBListener (..)) -import Pos.Core (Blockchain (..), EpochIndex, EpochOrSlot (..), - HasProtocolConstants, HeaderHash, SlotId (..), - chainQualityThreshold, epochIndexL, epochSlots, - flattenSlotId, getEpochOrSlot, headerHash) +import Pos.Core (BlockCount, Blockchain (..), EpochIndex, + EpochOrSlot (..), HeaderHash, ProtocolConstants, + SlotId (..), epochIndexL, flattenSlotId, getEpochOrSlot, + headerHash, kChainQualityThreshold, kEpochSlots, + localSlotIndexMinBound, pcBlkSecurityParam, pcEpochSlots) import Pos.Core.Block (BlockHeader (..), GenesisBlock, MainBlock, MainBlockchain) import qualified Pos.Core.Block as BC @@ -113,43 +114,46 @@ type MonadCreateBlock ctx m -- In the former case, it doesn't make sense to create a block. -- In the latter case, we want the system to stop completely, rather -- than running in insecure mode. -createGenesisBlockAndApply :: - forall ctx m. - ( MonadCreateBlock ctx m +createGenesisBlockAndApply + :: forall ctx m + . ( MonadCreateBlock ctx m , CanJsonLog m , HasLens StateLock ctx StateLock - , HasLens (StateLockMetrics MemPoolModifyReason) ctx (StateLockMetrics MemPoolModifyReason) + , HasLens + (StateLockMetrics MemPoolModifyReason) + ctx + (StateLockMetrics MemPoolModifyReason) , HasMisbehaviorMetrics ctx ) => ProtocolMagic + -> ProtocolConstants -> EpochIndex -> m (Maybe GenesisBlock) -- Genesis block for 0-th epoch is hardcoded. -createGenesisBlockAndApply _ 0 = pure Nothing -createGenesisBlockAndApply pm epoch = do +createGenesisBlockAndApply _ _ 0 = pure Nothing +createGenesisBlockAndApply pm pc epoch = do tipHeader <- DB.getTipHeader -- preliminary check outside the lock, -- must be repeated inside the lock - needGen <- needCreateGenesisBlock epoch tipHeader + needGen <- needCreateGenesisBlock (pcBlkSecurityParam pc) epoch tipHeader if needGen then modifyStateLock HighPriority ApplyBlock - (\_ -> createGenesisBlockDo pm epoch) + (\_ -> createGenesisBlockDo pm pc epoch) else return Nothing createGenesisBlockDo - :: forall ctx m. - ( MonadCreateBlock ctx m - , HasMisbehaviorMetrics ctx - ) + :: forall ctx m + . (MonadCreateBlock ctx m, HasMisbehaviorMetrics ctx) => ProtocolMagic + -> ProtocolConstants -> EpochIndex -> m (HeaderHash, Maybe GenesisBlock) -createGenesisBlockDo pm epoch = do +createGenesisBlockDo pm pc epoch = do tipHeader <- DB.getTipHeader logDebug $ sformat msgTryingFmt epoch tipHeader - needCreateGenesisBlock epoch tipHeader >>= \case + needCreateGenesisBlock (pcBlkSecurityParam pc) epoch tipHeader >>= \case False -> (BC.blockHeaderHash tipHeader, Nothing) <$ logShouldNot True -> actuallyCreate tipHeader where @@ -158,17 +162,17 @@ createGenesisBlockDo pm epoch = do -- Note that it shouldn't fail, because 'shouldCreate' guarantees that we -- have enough blocks for LRC. actuallyCreate tipHeader = do - lrcSingleShot pm epoch + lrcSingleShot pm pc epoch leaders <- lrcActionOnEpochReason epoch "createGenesisBlockDo " LrcDB.getLeadersForEpoch let blk = mkGenesisBlock pm (Right tipHeader) epoch leaders let newTip = headerHash blk - verifyBlocksPrefix pm (one (Left blk)) >>= \case + verifyBlocksPrefix pm pc (one (Left blk)) >>= \case Left err -> reportFatalError $ pretty err Right (undos, pollModifier) -> do let undo = undos ^. _Wrapped . _neHead - applyBlocksUnsafe pm (ShouldCallBListener True) (one (Left blk, undo)) (Just pollModifier) - normalizeMempool pm + applyBlocksUnsafe pm pc (ShouldCallBListener True) (one (Left blk, undo)) (Just pollModifier) + normalizeMempool pm pc pure (newTip, Just blk) logShouldNot = logDebug @@ -177,27 +181,32 @@ createGenesisBlockDo pm epoch = do "We are trying to create genesis block for " %ords % " epoch, our tip header is\n" %build -needCreateGenesisBlock :: - ( MonadCreateBlock ctx m - ) - => EpochIndex +needCreateGenesisBlock + :: MonadCreateBlock ctx m + => BlockCount + -> EpochIndex -> BlockHeader -> m Bool -needCreateGenesisBlock epoch tipHeader = do +needCreateGenesisBlock k epoch tipHeader = do case tipHeader of - BlockHeaderGenesis _ -> pure False + BlockHeaderGenesis _ -> pure False -- This is true iff tip is from 'epoch' - 1 and last -- 'blkSecurityParam' blocks fully fit into last -- 'slotSecurityParam' slots from 'epoch' - 1. - BlockHeaderMain mb -> - if mb ^. epochIndexL /= epoch - 1 - then pure False - else calcChainQualityM (flattenSlotId $ SlotId epoch minBound) <&> \case - Nothing -> False -- if we can't compute chain - -- quality, we probably - -- shouldn't try to create - -- blocks - Just cq -> chainQualityThreshold @Double <= cq + BlockHeaderMain mb -> if mb ^. epochIndexL /= epoch - 1 + then pure False + else + calcChainQualityM + k + ( flattenSlotId (kEpochSlots k) + $ SlotId epoch localSlotIndexMinBound + ) + <&> \case + Nothing -> False -- if we can't compute chain + -- quality, we probably + -- shouldn't try to create + -- blocks + Just cq -> kChainQualityThreshold @Double k <= cq ---------------------------------------------------------------------------- -- MainBlock @@ -214,24 +223,25 @@ needCreateGenesisBlock epoch tipHeader = do -- In theory we can create main block even if chain quality is -- bad. See documentation of 'createGenesisBlock' which explains why -- we don't create blocks in such cases. -createMainBlockAndApply :: - forall ctx m. - ( MonadCreateBlock ctx m +createMainBlockAndApply + :: forall ctx m + . ( MonadCreateBlock ctx m , CanJsonLog m , HasLens' ctx StateLock , HasLens' ctx (StateLockMetrics MemPoolModifyReason) ) => ProtocolMagic + -> ProtocolConstants -> SlotId -> ProxySKBlockInfo -> m (Either Text MainBlock) -createMainBlockAndApply pm sId pske = +createMainBlockAndApply pm pc sId pske = modifyStateLock HighPriority ApplyBlock createAndApply where createAndApply tip = - createMainBlockInternal pm sId pske >>= \case + createMainBlockInternal pm (pcBlkSecurityParam pc) sId pske >>= \case Left reason -> pure (tip, Left reason) - Right blk -> convertRes <$> applyCreatedBlock pm pske blk + Right blk -> convertRes <$> applyCreatedBlock pm pc pske blk convertRes createdBlk = (headerHash createdBlk, Right createdBlk) ---------------------------------------------------------------------------- @@ -243,40 +253,42 @@ createMainBlockAndApply pm sId pske = -- (hence 'Internal' suffix). It doesn't apply or verify created -- block. It only checks whether a block can be created (see -- 'createMainBlockAndApply') and creates it checks passes. -createMainBlockInternal :: - forall ctx m. - ( MonadCreateBlock ctx m - ) +createMainBlockInternal + :: forall ctx m + . (MonadCreateBlock ctx m) => ProtocolMagic + -> BlockCount -> SlotId -> ProxySKBlockInfo -> m (Either Text MainBlock) -createMainBlockInternal pm sId pske = do +createMainBlockInternal pm k sId pske = do tipHeader <- DB.getTipHeader logInfoS $ sformat msgFmt tipHeader - canCreateBlock sId tipHeader >>= \case + canCreateBlock k sId tipHeader >>= \case Left reason -> pure (Left reason) Right () -> runExceptT (createMainBlockFinish tipHeader) where 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 (headerHash prevHeader) sId + rawPay <- lift $ getRawPayload k (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 -- than limit. So i guess it's fine in general. sizeLimit <- (\x -> bool 0 (x - 100) (x > 100)) <$> lift UDB.getMaxBlockSize - block <- createMainBlockPure pm sizeLimit prevHeader pske sId sk rawPay + block <- createMainBlockPure pm k sizeLimit prevHeader pske sId sk rawPay logInfoS $ "Created main block of size: " <> sformat memory (biSize block) block <$ evaluateNF_ block -canCreateBlock :: MonadCreateBlock ctx m - => SlotId +canCreateBlock + :: MonadCreateBlock ctx m + => BlockCount + -> SlotId -> BlockHeader -> m (Either Text ()) -canCreateBlock sId tipHeader = +canCreateBlock k sId tipHeader = runExceptT $ do unlessM (lift usCanCreateBlock) $ throwError "this software is obsolete and can't create block" @@ -284,19 +296,19 @@ canCreateBlock sId tipHeader = throwError "slot id is not greater than one from the tip block" unless (tipHeader ^. epochIndexL == siEpoch sId) $ throwError "we don't know genesis block for this epoch" - let flatSId = flattenSlotId sId + let flatSId = flattenSlotId (kEpochSlots k) sId -- Small heuristic: let's not check chain quality during the -- first quarter of the 0-th epoch, because during this time -- weird things can happen (we just launched the system) and -- usually we monitor it manually anyway. - unless (flatSId <= fromIntegral (epochSlots `div` 4)) $ do - chainQualityMaybe <- calcChainQualityM flatSId + unless (flatSId <= fromIntegral (kEpochSlots k `div` 4)) $ do + chainQualityMaybe <- calcChainQualityM k flatSId chainQuality <- maybe (throwError "can't compute chain quality") pure chainQualityMaybe - unless (chainQuality >= chainQualityThreshold @Double) $ + unless (chainQuality >= kChainQualityThreshold @Double k) $ throwError $ sformat ("chain quality is below threshold: "%fixed 3) @@ -306,9 +318,10 @@ canCreateBlock sId tipHeader = tipEOS = getEpochOrSlot tipHeader createMainBlockPure - :: forall m. - ( MonadError Text m, HasUpdateConfiguration, HasProtocolConstants ) + :: forall m + . (MonadError Text m, HasUpdateConfiguration) => ProtocolMagic + -> BlockCount -> Byte -- ^ Block size limit (real max.value) -> BlockHeader -> ProxySKBlockInfo @@ -316,14 +329,14 @@ createMainBlockPure -> SecretKey -> RawPayload -> m MainBlock -createMainBlockPure pm limit prevHeader pske sId sk rawPayload = do +createMainBlockPure pm k limit prevHeader pske sId sk rawPayload = do bodyLimit <- execStateT computeBodyLimit limit - body <- createMainBody bodyLimit sId rawPayload + body <- createMainBody k bodyLimit sId rawPayload pure (mkMainBlock pm bv sv (Right prevHeader) sId sk pske body) where -- default ssc to put in case we won't fit a normal one defSsc :: SscPayload - defSsc = defaultSscPayload (siSlot sId) + defSsc = defaultSscPayload k (siSlot sId) computeBodyLimit :: StateT Byte m () computeBodyLimit = do -- account for block header and serialization overhead, etc; @@ -347,21 +360,20 @@ createMainBlockPure pm limit prevHeader pske sId sk rawPayload = do -- all mempools and try to create a block again. The returned value is -- the block we applied (usually it's the same as the argument, but -- can differ if verification fails). -applyCreatedBlock :: - forall ctx m. - ( MonadBlockApply ctx m - , MonadCreateBlock ctx m - ) +applyCreatedBlock + :: forall ctx m + . (MonadBlockApply ctx m, MonadCreateBlock ctx m) => ProtocolMagic + -> ProtocolConstants -> ProxySKBlockInfo -> MainBlock -> m MainBlock -applyCreatedBlock pm pske createdBlock = applyCreatedBlockDo False createdBlock +applyCreatedBlock pm pc pske createdBlock = applyCreatedBlockDo False createdBlock where slotId = createdBlock ^. BC.mainBlockSlot applyCreatedBlockDo :: Bool -> MainBlock -> m MainBlock applyCreatedBlockDo isFallback blockToApply = - verifyBlocksPrefix pm (one (Right blockToApply)) >>= \case + verifyBlocksPrefix pm pc (one (Right blockToApply)) >>= \case Left (pretty -> reason) | isFallback -> onFailedFallback reason | otherwise -> fallback reason @@ -369,15 +381,16 @@ applyCreatedBlock pm pske createdBlock = applyCreatedBlockDo False createdBlock let undo = undos ^. _Wrapped . _neHead applyBlocksUnsafe pm + pc (ShouldCallBListener True) (one (Right blockToApply, undo)) (Just pollModifier) - normalizeMempool pm + normalizeMempool pm pc pure blockToApply clearMempools :: m () clearMempools = do withTxpLocalData clearTxpMemPool - sscResetLocal + sscResetLocal $ pcEpochSlots pc clearUSMemPool clearDlgMemPool fallback :: Text -> m MainBlock @@ -388,7 +401,7 @@ applyCreatedBlock pm pske createdBlock = applyCreatedBlockDo False createdBlock logDebug $ "Clearing mempools" clearMempools logDebug $ "Creating empty block" - createMainBlockInternal pm slotId pske >>= \case + createMainBlockInternal pm (pcBlkSecurityParam pc) slotId pske >>= \case Left err -> assertionFailed $ sformat ("Couldn't create a block in fallback: "%stext) err @@ -409,13 +422,15 @@ data RawPayload = RawPayload , rpUpdate :: !UpdatePayload } -getRawPayload :: MonadCreateBlock ctx m - => HeaderHash +getRawPayload + :: MonadCreateBlock ctx m + => BlockCount + -> HeaderHash -> SlotId -> m RawPayload -getRawPayload tip slotId = do +getRawPayload k tip slotId = do localTxs <- txGetPayload tip -- result is topsorted - sscData <- sscGetLocalPayload slotId + sscData <- sscGetLocalPayload k slotId usPayload <- usPreparePayload tip slotId dlgPayload <- getDlgMempool let rawPayload = @@ -433,16 +448,17 @@ getRawPayload tip slotId = do -- -- Given limit applies only to body, not to other data from block. createMainBody - :: forall m . - ( MonadError Text m, HasProtocolConstants ) - => Byte -- ^ Body limit + :: forall m + . MonadError Text m + => BlockCount + -> Byte -- ^ Body limit -> SlotId -> RawPayload -> m (Body MainBlockchain) -createMainBody bodyLimit sId payload = +createMainBody k bodyLimit sId payload = flip evalStateT bodyLimit $ do let defSsc :: SscPayload - defSsc = defaultSscPayload (siSlot sId) + defSsc = defaultSscPayload k (siSlot sId) -- include ssc data limited with max half of block space if it's possible sscPayload <- ifM (uses identity (<= biSize defSsc)) (pure defSsc) $ do halfLeft <- uses identity (`div` 2) @@ -455,7 +471,7 @@ createMainBody bodyLimit sId payload = pure sscP -- include delegation certificates and US payload - let prioritizeUS = even (flattenSlotId sId) + let prioritizeUS = even (flattenSlotId (kEpochSlots k) sId) let psks = getDlgPayload dlgPay (psks', usPayload') <- if prioritizeUS then do diff --git a/block/src/Pos/Block/Logic/Header.hs b/block/src/Pos/Block/Logic/Header.hs index 937cc93a158..c55cb0ab105 100644 --- a/block/src/Pos/Block/Logic/Header.hs +++ b/block/src/Pos/Block/Logic/Header.hs @@ -33,11 +33,11 @@ import UnliftIO (MonadUnliftIO) import Pos.Block.Logic.Integrity (VerifyHeaderParams (..), verifyHeader, verifyHeaders) import Pos.Block.Logic.Util (lcaWithMainChain) -import Pos.Core (BlockCount, EpochOrSlot (..), HeaderHash, - SlotId (..), blkSecurityParam, bvdMaxHeaderSize, - difficultyL, epochIndexL, epochOrSlotG, - getChainDifficulty, getEpochOrSlot, headerHash, - headerHashG, headerSlotL, prevBlockL) +import Pos.Core (BlockCount, EpochOrSlot (..), HeaderHash, SlotCount, + SlotId (..), bvdMaxHeaderSize, difficultyL, epochIndexL, + epochOrSlotG, getChainDifficulty, getEpochOrSlot, + headerHash, headerHashG, headerSlotL, kEpochSlots, + localSlotIndexMinBound, prevBlockL) import Pos.Core.Block (BlockHeader (..)) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst, toOldestFirst, _NewestFirst, _OldestFirst) @@ -77,16 +77,16 @@ mkCHRinvalid = CHInvalid . T.intercalate "; " -- | Classify new header announced by some node. Result is represented -- as ClassifyHeaderRes type. classifyNewHeader - :: forall ctx m. - ( MonadSlots ctx m - , MonadDBRead m - , MonadUnliftIO m - ) - => ProtocolMagic -> BlockHeader -> m ClassifyHeaderRes + :: forall ctx m + . (MonadSlots ctx m, MonadDBRead m, MonadUnliftIO m) + => ProtocolMagic + -> SlotCount + -> BlockHeader + -> m ClassifyHeaderRes -- Genesis headers seem useless, we can create them by ourselves. -classifyNewHeader _ (BlockHeaderGenesis _) = pure $ CHUseless "genesis header is useless" -classifyNewHeader pm (BlockHeaderMain header) = fmap (either identity identity) <$> runExceptT $ do - curSlot <- getCurrentSlot +classifyNewHeader _ _ (BlockHeaderGenesis _) = pure $ CHUseless "genesis header is useless" +classifyNewHeader pm epochSlots (BlockHeaderMain header) = fmap (either identity identity) <$> runExceptT $ do + curSlot <- getCurrentSlot epochSlots tipHeader <- lift DB.getTipHeader let tipEoS = getEpochOrSlot tipHeader let newHeaderEoS = getEpochOrSlot header @@ -171,10 +171,11 @@ classifyHeaders :: , WithLogger m ) => ProtocolMagic + -> BlockCount -> Bool -- recovery in progress? -> NewestFirst NE BlockHeader -> m ClassifyHeadersRes -classifyHeaders pm inRecovery headers = do +classifyHeaders pm k inRecovery headers = do tipHeader <- DB.getTipHeader let tip = headerHash tipHeader haveOldestParent <- isJust <$> DB.getHeader oldestParentHash @@ -182,10 +183,10 @@ classifyHeaders pm inRecovery headers = do let headersValid = isVerSuccess $ verifyHeaders pm leaders (headers & _NewestFirst %~ toList) - mbCurrentSlot <- getCurrentSlot + mbCurrentSlot <- getCurrentSlot $ kEpochSlots k let newestHeaderConvertedSlot = case newestHeader ^. epochOrSlotG of - EpochOrSlot (Left e) -> SlotId e minBound + EpochOrSlot (Left e) -> SlotId e localSlotIndexMinBound EpochOrSlot (Right s) -> s if | newestHash == headerHash tip -> @@ -238,11 +239,11 @@ classifyHeaders pm inRecovery headers = do pure $ if | hash lca == hash tipHeader -> CHsValid lcaChild | depthDiff < 0 -> error "classifyHeaders@depthDiff is negative" - | depthDiff > blkSecurityParam -> + | depthDiff > k -> CHsUseless $ sformat ("Difficulty difference of (tip,lca) is "%int% " which is more than blkSecurityParam = "%int) - depthDiff blkSecurityParam + depthDiff k | otherwise -> CHsValid lcaChild @@ -310,8 +311,10 @@ getHeadersFromManyTo mLimit checkpoints startM = runExceptT $ do -- exponentially base 2 relatively to the depth in the blockchain. getHeadersOlderExp :: MonadDBRead m - => Maybe HeaderHash -> m (OldestFirst NE HeaderHash) -getHeadersOlderExp upto = do + => BlockCount + -> Maybe HeaderHash + -> m (OldestFirst NE HeaderHash) +getHeadersOlderExp k upto = do tip <- GS.getTip let upToReal = fromMaybe tip upto -- Using 'blkSecurityParam + 1' because fork can happen on k+1th one. @@ -319,7 +322,7 @@ getHeadersOlderExp upto = do -- loadHeadersByDepth always returns nonempty list unless you -- pass depth 0 (we pass k+1). It throws if upToReal is -- absent. So it either throws or returns nonempty. - DB.loadHeadersByDepth (blkSecurityParam + 1) upToReal + DB.loadHeadersByDepth (k + 1) upToReal let toNE = fromMaybe (error "getHeadersOlderExp: couldn't create nonempty") . nonEmpty let selectedHashes :: NewestFirst [] HeaderHash diff --git a/block/src/Pos/Block/Logic/Integrity.hs b/block/src/Pos/Block/Logic/Integrity.hs index 3ac6e7770d3..538c904c7a7 100644 --- a/block/src/Pos/Block/Logic/Integrity.hs +++ b/block/src/Pos/Block/Logic/Integrity.hs @@ -28,10 +28,9 @@ import Pos.Binary.Update () import qualified Pos.Block.BHelpers as BHelpers import Pos.Core (BlockVersionData (..), ChainDifficulty, EpochOrSlot, HasDifficulty (..), HasEpochIndex (..), - HasEpochOrSlot (..), HasHeaderHash (..), - HasProtocolConstants, HeaderHash, SlotId (..), - SlotLeaders, addressHash, gbExtra, gbhExtra, getSlotIndex, - headerSlotL, prevBlockL) + HasEpochOrSlot (..), HasHeaderHash (..), HeaderHash, + ProtocolConstants, SlotId (..), SlotLeaders, addressHash, + gbExtra, gbhExtra, getSlotIndex, headerSlotL, prevBlockL) import Pos.Core.Block (Block, BlockHeader (..), blockHeaderProtocolMagic, gebAttributes, gehAttributes, genBlockLeaders, getBlockHeader, mainHeaderLeaderKey, @@ -254,13 +253,13 @@ data VerifyBlockParams = VerifyBlockParams -- 2. The size of each block does not exceed `bvdMaxBlockSize`. -- 3. (Optional) No block has any unknown attributes. verifyBlock - :: HasProtocolConstants - => ProtocolMagic + :: ProtocolMagic + -> ProtocolConstants -> VerifyBlockParams -> Block -> VerificationRes -verifyBlock pm VerifyBlockParams {..} blk = mconcat - [ verifyFromEither "internal block consistency" (BHelpers.verifyBlock pm blk) +verifyBlock pm pc VerifyBlockParams {..} blk = mconcat + [ verifyFromEither "internal block consistency" (BHelpers.verifyBlock pm pc blk) , verifyHeader pm vbpVerifyHeader (getBlockHeader blk) , checkSize vbpMaxSize , bool mempty (verifyNoUnknown blk) vbpVerifyNoUnknown @@ -303,15 +302,15 @@ type VerifyBlocksIter = (SlotLeaders, Maybe BlockHeader, VerificationRes) -- laziness of 'VerificationRes' which is good because laziness for this data -- type is crucial. verifyBlocks - :: HasProtocolConstants - => ProtocolMagic + :: ProtocolMagic + -> ProtocolConstants -> Maybe SlotId -> Bool -> BlockVersionData -> SlotLeaders -> OldestFirst [] Block -> VerificationRes -verifyBlocks pm curSlotId verifyNoUnknown bvd initLeaders = view _3 . foldl' step start +verifyBlocks pm pc curSlotId verifyNoUnknown bvd initLeaders = view _3 . foldl' step start where start :: VerifyBlocksIter -- Note that here we never know previous header before this @@ -340,4 +339,4 @@ verifyBlocks pm curSlotId verifyNoUnknown bvd initLeaders = view _3 . foldl' ste , vbpMaxSize = bvdMaxBlockSize bvd , vbpVerifyNoUnknown = verifyNoUnknown } - in (newLeaders, Just $ getBlockHeader blk, res <> verifyBlock pm vbp blk) + in (newLeaders, Just $ getBlockHeader blk, res <> verifyBlock pm pc vbp blk) diff --git a/block/src/Pos/Block/Logic/Internal.hs b/block/src/Pos/Block/Logic/Internal.hs index 687a58de650..07cef42bb5b 100644 --- a/block/src/Pos/Block/Logic/Internal.hs +++ b/block/src/Pos/Block/Logic/Internal.hs @@ -38,10 +38,11 @@ import Pos.Block.Slog (BypassSecurityCheck (..), MonadSlogApply, MonadSlogBase, ShouldCallBListener, slogApplyBlocks, slogRollbackBlocks) import Pos.Block.Types (Blund, Undo (undoDlg, undoTx, undoUS)) -import Pos.Core (ComponentBlock (..), IsGenesisHeader, epochIndexL, - gbHeader, headerHash, mainBlockDlgPayload, - mainBlockSscPayload, mainBlockTxPayload, - mainBlockUpdatePayload) +import Pos.Core (ComponentBlock (..), IsGenesisHeader, + ProtocolConstants, epochIndexL, gbHeader, headerHash, + mainBlockDlgPayload, mainBlockSscPayload, + mainBlockTxPayload, mainBlockUpdatePayload, + pcBlkSecurityParam, pcEpochSlots) import Pos.Core.Block (Block, GenesisBlock, MainBlock) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Crypto (ProtocolMagic) @@ -128,13 +129,17 @@ type MonadMempoolNormalization ctx m ) -- | Normalize mempool. -normalizeMempool :: MonadMempoolNormalization ctx m => ProtocolMagic -> m () -normalizeMempool pm = do +normalizeMempool + :: MonadMempoolNormalization ctx m + => ProtocolMagic + -> ProtocolConstants + -> m () +normalizeMempool pm pc = do -- We normalize all mempools except the delegation one. -- That's because delegation mempool normalization is harder and is done -- within block application. - sscNormalize pm - txpNormalize pm + sscNormalize pm pc + txpNormalize pm (pcEpochSlots pc) usNormalize -- | Applies a definitely valid prefix of blocks. This function is unsafe, @@ -147,11 +152,12 @@ applyBlocksUnsafe , HasTxpConfiguration ) => ProtocolMagic + -> ProtocolConstants -> ShouldCallBListener -> OldestFirst NE Blund -> Maybe PollModifier -> m () -applyBlocksUnsafe pm scb blunds pModifier = do +applyBlocksUnsafe pm pc scb blunds pModifier = do -- Check that all blunds have the same epoch. unless (null nextEpoch) $ assertionFailed $ sformat ("applyBlocksUnsafe: tried to apply more than we should"% @@ -171,7 +177,7 @@ applyBlocksUnsafe pm scb blunds pModifier = do (b@(Left _,_):|(x:xs)) -> app' (b:|[]) >> app' (x:|xs) _ -> app blunds where - app x = applyBlocksDbUnsafeDo pm scb x pModifier + app x = applyBlocksDbUnsafeDo pm pc scb x pModifier app' = app . OldestFirst (thisEpoch, nextEpoch) = spanSafe ((==) `on` view (_1 . epochIndexL)) $ getOldestFirst blunds @@ -181,29 +187,29 @@ applyBlocksDbUnsafeDo , HasTxpConfiguration ) => ProtocolMagic + -> ProtocolConstants -> ShouldCallBListener -> OldestFirst NE Blund -> Maybe PollModifier -> m () -applyBlocksDbUnsafeDo pm scb blunds pModifier = do +applyBlocksDbUnsafeDo pm pc scb blunds pModifier = do let blocks = fmap fst blunds -- Note: it's important to do 'slogApplyBlocks' first, because it -- puts blocks in DB. - slogBatch <- slogApplyBlocks scb blunds + slogBatch <- slogApplyBlocks (pcBlkSecurityParam pc) scb blunds TxpGlobalSettings {..} <- view (lensOf @TxpGlobalSettings) - usBatch <- SomeBatchOp <$> usApplyBlocks pm (map toUpdateBlock blocks) pModifier + usBatch <- + SomeBatchOp + <$> usApplyBlocks pm + (pcBlkSecurityParam pc) + (map toUpdateBlock blocks) + pModifier delegateBatch <- SomeBatchOp <$> dlgApplyBlocks (map toDlgBlund blunds) - txpBatch <- tgsApplyBlocks $ map toTxpBlund blunds - sscBatch <- SomeBatchOp <$> - -- TODO: pass not only 'Nothing' - sscApplyBlocks pm (map toSscBlock blocks) Nothing - GS.writeBatchGState - [ delegateBatch - , usBatch - , txpBatch - , sscBatch - , slogBatch - ] + txpBatch <- tgsApplyBlocks $ map toTxpBlund blunds + -- TODO: pass not only 'Nothing' + sscBatch <- + SomeBatchOp <$> sscApplyBlocks pm pc (map toSscBlock blocks) Nothing + GS.writeBatchGState [delegateBatch, usBatch, txpBatch, sscBatch, slogBatch] sanityCheckDB -- | Rollback sequence of blocks, head-newest order expected with head being @@ -211,27 +217,22 @@ applyBlocksDbUnsafeDo pm scb blunds pModifier = do rollbackBlocksUnsafe :: MonadBlockApply ctx m => ProtocolMagic + -> ProtocolConstants -> BypassSecurityCheck -- ^ is rollback for more than k blocks allowed? -> ShouldCallBListener -> NewestFirst NE Blund -> m () -rollbackBlocksUnsafe pm bsc scb toRollback = do - slogRoll <- slogRollbackBlocks bsc scb toRollback - dlgRoll <- SomeBatchOp <$> dlgRollbackBlocks (map toDlgBlund toRollback) - usRoll <- SomeBatchOp <$> usRollbackBlocks - (toRollback & each._2 %~ undoUS - & each._1 %~ toUpdateBlock) +rollbackBlocksUnsafe pm pc bsc scb toRollback = do + slogRoll <- slogRollbackBlocks pc bsc scb toRollback + dlgRoll <- SomeBatchOp <$> dlgRollbackBlocks (map toDlgBlund toRollback) + usRoll <- SomeBatchOp <$> usRollbackBlocks + (toRollback & each . _2 %~ undoUS & each . _1 %~ toUpdateBlock) TxpGlobalSettings {..} <- view (lensOf @TxpGlobalSettings) - txRoll <- tgsRollbackBlocks $ map toTxpBlund toRollback - sscBatch <- SomeBatchOp <$> sscRollbackBlocks + txRoll <- tgsRollbackBlocks $ map toTxpBlund toRollback + sscBatch <- SomeBatchOp <$> sscRollbackBlocks + (pcEpochSlots pc) (map (toSscBlock . fst) toRollback) - GS.writeBatchGState - [ dlgRoll - , usRoll - , txRoll - , sscBatch - , slogRoll - ] + GS.writeBatchGState [dlgRoll, usRoll, txRoll, sscBatch, slogRoll] -- After blocks are rolled back it makes sense to recreate the -- delegation mempool. -- We don't normalize other mempools, because they are normalized diff --git a/block/src/Pos/Block/Logic/Util.hs b/block/src/Pos/Block/Logic/Util.hs index c6bfee14027..24f02f69667 100644 --- a/block/src/Pos/Block/Logic/Util.hs +++ b/block/src/Pos/Block/Logic/Util.hs @@ -26,12 +26,11 @@ import System.Wlog (WithLogger) import Pos.Block.Configuration (HasBlockConfiguration, fixedTimeCQ) import Pos.Block.Slog.Context (slogGetLastSlots) import Pos.Block.Slog.Types (HasSlogGState) -import Pos.Core (BlockCount, FlatSlotId, HasProtocolConstants, - HeaderHash, Timestamp (..), difficultyL, flattenSlotId, - headerHash, prevBlockL) +import Pos.Core (BlockCount, FlatSlotId, HeaderHash, SlotCount, + Timestamp (..), difficultyL, flattenSlotId, headerHash, + prevBlockL) import Pos.Core.Block (BlockHeader) import Pos.Core.Chrono (NE, OldestFirst (..)) -import Pos.Core.Configuration (blkSecurityParam) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadBlockDBRead) import Pos.Exception (reportFatalError) @@ -96,24 +95,24 @@ calcChainQuality blockCount deepSlot newSlot -- | Version of 'calcChainQuality' which takes last blocks' slots from -- the monadic context. It computes chain quality for last -- 'blkSecurityParam' blocks. -calcChainQualityM :: - ( MonadReader ctx m +calcChainQualityM + :: ( MonadReader ctx m , HasSlogGState ctx , MonadIO m , MonadThrow m , WithLogger m , Fractional res - , HasProtocolConstants ) - => FlatSlotId + => BlockCount + -> FlatSlotId -> m (Maybe res) -calcChainQualityM newSlot = do +calcChainQualityM k newSlot = do OldestFirst lastSlots <- slogGetLastSlots let len = length lastSlots case nonEmpty lastSlots of Nothing -> return Nothing Just slotsNE - | len > fromIntegral blkSecurityParam -> + | len > fromIntegral k -> reportFatalError $ sformat ("number of last slots is greater than 'k': "%int) len @@ -127,12 +126,13 @@ calcChainQualityM newSlot = do -- | Calculate overall chain quality, i. e. number of main blocks -- divided by number of slots so far. Returns 'Nothing' if current -- slot is unknown. -calcOverallChainQuality :: - forall ctx m res. - (Fractional res, MonadSlots ctx m, MonadBlockDBRead m) - => m (Maybe res) -calcOverallChainQuality = - getCurrentSlotFlat >>= \case +calcOverallChainQuality + :: forall ctx m res + . (Fractional res, MonadSlots ctx m, MonadBlockDBRead m) + => SlotCount + -> m (Maybe res) +calcOverallChainQuality epochSlots = + getCurrentSlotFlat epochSlots >>= \case Nothing -> pure Nothing Just curFlatSlot -> calcOverallChainQualityDo curFlatSlot <$> DB.getTipHeader @@ -154,20 +154,20 @@ calcOverallChainQuality = -- 2160 'fixedTimeCQ' can be even 12h. We want 1h, so it's not -- restrictive at all. -- 3. We are able to determine which slot started 'fixedTimeCQ' ago. -calcChainQualityFixedTime :: - forall ctx m res. - ( Fractional res +calcChainQualityFixedTime + :: forall ctx m res + . ( Fractional res , MonadSlots ctx m , HasBlockConfiguration , HasSlogGState ctx - , HasProtocolConstants ) - => m (Maybe res) -calcChainQualityFixedTime = do + => SlotCount + -> m (Maybe res) +calcChainQualityFixedTime epochSlots = do Timestamp curTime <- currentTimeSlotting let olderTime = Timestamp (curTime - fixedTimeCQ) - (,) <$> slotFromTimestamp olderTime <*> getCurrentSlotFlat >>= \case - (Just (flattenSlotId -> olderSlotId), Just currentSlotId) -> + (,) <$> slotFromTimestamp epochSlots olderTime <*> getCurrentSlotFlat epochSlots >>= \case + (Just (flattenSlotId epochSlots -> olderSlotId), Just currentSlotId) -> calcChainQualityFixedTimeDo olderSlotId currentSlotId <$> slogGetLastSlots _ -> return Nothing diff --git a/block/src/Pos/Block/Logic/VAR.hs b/block/src/Pos/Block/Logic/VAR.hs index 154817533aa..471c105cf46 100644 --- a/block/src/Pos/Block/Logic/VAR.hs +++ b/block/src/Pos/Block/Logic/VAR.hs @@ -33,8 +33,8 @@ import Pos.Block.Lrc (LrcModeFull, lrcSingleShot) import Pos.Block.Slog (ShouldCallBListener (..), mustDataBeKnown, slogVerifyBlocks) import Pos.Block.Types (Blund, Undo (..)) -import Pos.Core (Block, HeaderHash, epochIndexL, headerHashG, - prevBlockL) +import Pos.Core (Block, HeaderHash, ProtocolConstants, epochIndexL, + headerHashG, pcBlkSecurityParam, prevBlockL) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst, toOldestFirst) import Pos.Crypto (ProtocolMagic) @@ -70,14 +70,13 @@ import Pos.Util.Util (HasLens (..)) -- 3. Ensure that the number of undos from @txp@ and @dlg@ is the same. -- 4. Return all undos. verifyBlocksPrefix - :: forall ctx m. - ( HasTxpConfiguration - , MonadBlockVerify ctx m - ) + :: forall ctx m + . (HasTxpConfiguration, MonadBlockVerify ctx m) => ProtocolMagic + -> ProtocolConstants -> OldestFirst NE Block -> m (Either VerifyBlocksException (OldestFirst NE Undo, PollModifier)) -verifyBlocksPrefix pm blocks = runExceptT $ do +verifyBlocksPrefix pm pc blocks = runExceptT $ do -- This check (about tip) is here just in case, we actually check -- it before calling this function. tip <- lift GS.getTip @@ -93,15 +92,15 @@ verifyBlocksPrefix pm blocks = runExceptT $ do -- the internal consistency checks formerly done in the 'Bi' instance -- 'decode'. slogUndos <- withExceptT VerifyBlocksError $ - ExceptT $ slogVerifyBlocks pm blocks + ExceptT $ slogVerifyBlocks pm pc blocks _ <- withExceptT (VerifyBlocksError . pretty) $ - ExceptT $ sscVerifyBlocks pm (map toSscBlock blocks) + ExceptT $ sscVerifyBlocks pm pc (map toSscBlock blocks) TxpGlobalSettings {..} <- view (lensOf @TxpGlobalSettings) txUndo <- withExceptT (VerifyBlocksError . pretty) $ ExceptT $ tgsVerifyBlocks dataMustBeKnown $ map toTxpBlock blocks pskUndo <- withExceptT VerifyBlocksError $ dlgVerifyBlocks pm blocks (pModifier, usUndos) <- withExceptT (VerifyBlocksError . pretty) $ - ExceptT $ usVerifyBlocks pm dataMustBeKnown (map toUpdateBlock blocks) + ExceptT $ usVerifyBlocks pm (pcBlkSecurityParam pc) dataMustBeKnown (map toUpdateBlock blocks) -- Eventually we do a sanity check just in case and return the result. when (length txUndo /= length pskUndo) $ @@ -134,16 +133,17 @@ verifyAndApplyBlocks , HasMisbehaviorMetrics ctx ) => ProtocolMagic + -> ProtocolConstants -> Bool -> OldestFirst NE Block -> m (Either ApplyBlocksException HeaderHash) -verifyAndApplyBlocks pm rollback blocks = runExceptT $ do +verifyAndApplyBlocks pm pc rollback blocks = runExceptT $ do tip <- lift GS.getTip let assumedTip = blocks ^. _Wrapped . _neHead . prevBlockL when (tip /= assumedTip) $ throwError $ ApplyBlocksTipMismatch "verify and apply" tip assumedTip hh <- rollingVerifyAndApply [] (spanEpoch blocks) - lift $ normalizeMempool pm + lift $ normalizeMempool pm pc pure hh where -- Spans input into @(a, b)@ where @a@ is either a single genesis @@ -166,11 +166,11 @@ verifyAndApplyBlocks pm rollback blocks = runExceptT $ do applyAMAP e (OldestFirst []) True = throwError e applyAMAP _ (OldestFirst []) False = lift GS.getTip applyAMAP e (OldestFirst (block:xs)) nothingApplied = - lift (verifyBlocksPrefix pm (one block)) >>= \case + lift (verifyBlocksPrefix pm pc (one block)) >>= \case Left (ApplyBlocksVerifyFailure -> e') -> applyAMAP e' (OldestFirst []) nothingApplied Right (OldestFirst (undo :| []), pModifier) -> do - lift $ applyBlocksUnsafe pm (ShouldCallBListener True) (one (block, undo)) (Just pModifier) + lift $ applyBlocksUnsafe pm pc (ShouldCallBListener True) (one (block, undo)) (Just pModifier) applyAMAP e (OldestFirst xs) False Right _ -> error "verifyAndApplyBlocksInternal: applyAMAP: \ \verification of one block produced more than one undo" @@ -181,7 +181,7 @@ verifyAndApplyBlocks pm rollback blocks = runExceptT $ do -> ExceptT ApplyBlocksException m HeaderHash failWithRollback e toRollback = do logDebug "verifyAndapply failed, rolling back" - lift $ mapM_ (rollbackBlocks pm) toRollback + lift $ mapM_ (rollbackBlocks pm pc) toRollback throwError e -- This function tries to apply a new portion of blocks (prefix -- and suffix). It also has an aggregating parameter @blunds@ which is @@ -199,9 +199,9 @@ verifyAndApplyBlocks pm rollback blocks = runExceptT $ do let epochIndex = prefixHead ^. epochIndexL logDebug $ "Rolling: Calculating LRC if needed for epoch " <> pretty epochIndex - lift $ lrcSingleShot pm epochIndex + lift $ lrcSingleShot pm pc epochIndex logDebug "Rolling: verifying" - lift (verifyBlocksPrefix pm prefix) >>= \case + lift (verifyBlocksPrefix pm pc prefix) >>= \case Left (ApplyBlocksVerifyFailure -> failure) | rollback -> failWithRollback failure blunds | otherwise -> do @@ -213,7 +213,7 @@ verifyAndApplyBlocks pm rollback blocks = runExceptT $ do let newBlunds = OldestFirst $ getOldestFirst prefix `NE.zip` getOldestFirst undos logDebug "Rolling: Verification done, applying unsafe block" - lift $ applyBlocksUnsafe pm (ShouldCallBListener True) newBlunds (Just pModifier) + lift $ applyBlocksUnsafe pm pc (ShouldCallBListener True) newBlunds (Just pModifier) case getOldestFirst suffix of [] -> lift GS.getTip (genesis:xs) -> do @@ -232,20 +232,21 @@ applyBlocks , HasMisbehaviorMetrics ctx ) => ProtocolMagic + -> ProtocolConstants -> Bool -> Maybe PollModifier -> OldestFirst NE Blund -> m () -applyBlocks pm calculateLrc pModifier blunds = do +applyBlocks pm pc calculateLrc pModifier blunds = do when (isLeft prefixHead && calculateLrc) $ -- Hopefully this lrc check is never triggered -- because -- caller most definitely should have computed lrc to verify -- the sequence beforehand. - lrcSingleShot pm (prefixHead ^. epochIndexL) - applyBlocksUnsafe pm (ShouldCallBListener True) prefix pModifier + lrcSingleShot pm pc (prefixHead ^. epochIndexL) + applyBlocksUnsafe pm pc (ShouldCallBListener True) prefix pModifier case getOldestFirst suffix of [] -> pass - (genesis:xs) -> applyBlocks pm calculateLrc pModifier (OldestFirst (genesis:|xs)) + (genesis:xs) -> applyBlocks pm pc calculateLrc pModifier (OldestFirst (genesis:|xs)) where prefixHead = prefix ^. _Wrapped . _neHead . _1 (prefix, suffix) = spanEpoch blunds @@ -259,13 +260,17 @@ applyBlocks pm calculateLrc pModifier blunds = do -- | Rollbacks blocks. Head must be the current tip. rollbackBlocks - :: (MonadBlockApply ctx m) => ProtocolMagic -> NewestFirst NE Blund -> m () -rollbackBlocks pm blunds = do + :: MonadBlockApply ctx m + => ProtocolMagic + -> ProtocolConstants + -> NewestFirst NE Blund + -> m () +rollbackBlocks pm pc blunds = do tip <- GS.getTip let firstToRollback = blunds ^. _Wrapped . _neHead . _1 . headerHashG when (tip /= firstToRollback) $ throwM $ RollbackTipMismatch tip firstToRollback - rollbackBlocksUnsafe pm (BypassSecurityCheck False) (ShouldCallBListener True) blunds + rollbackBlocksUnsafe pm pc (BypassSecurityCheck False) (ShouldCallBListener True) blunds -- | Rollbacks some blocks and then applies some blocks. applyWithRollback @@ -275,16 +280,18 @@ applyWithRollback , HasMisbehaviorMetrics ctx ) => ProtocolMagic + -> ProtocolConstants -> NewestFirst NE Blund -- ^ Blocks to rollbck -> OldestFirst NE Block -- ^ Blocks to apply -> m (Either ApplyBlocksException HeaderHash) -applyWithRollback pm toRollback toApply = runExceptT $ do +applyWithRollback pm pc toRollback toApply = runExceptT $ do tip <- lift GS.getTip when (tip /= newestToRollback) $ throwError $ ApplyBlocksTipMismatch "applyWithRollback/rollback" tip newestToRollback let doRollback = rollbackBlocksUnsafe pm + pc (BypassSecurityCheck False) (ShouldCallBListener True) toRollback @@ -298,7 +305,7 @@ applyWithRollback pm toRollback toApply = runExceptT $ do where reApply = toOldestFirst toRollback applyBack :: m () - applyBack = applyBlocks pm False Nothing reApply + applyBack = applyBlocks pm pc False Nothing reApply expectedTipApply = toApply ^. _Wrapped . _neHead . prevBlockL newestToRollback = toRollback ^. _Wrapped . _neHead . _1 . headerHashG @@ -306,6 +313,6 @@ applyWithRollback pm toRollback toApply = runExceptT $ do applyBack $> Left (ApplyBlocksTipMismatch "applyWithRollback/apply" tip newestToRollback) onGoodRollback = - verifyAndApplyBlocks pm True toApply >>= \case + verifyAndApplyBlocks pm pc True toApply >>= \case Left err -> applyBack $> Left err Right tipHash -> pure (Right tipHash) diff --git a/block/src/Pos/Block/Lrc.hs b/block/src/Pos/Block/Lrc.hs index d5c09bcbfb2..f9b43a9fa04 100644 --- a/block/src/Pos/Block/Lrc.hs +++ b/block/src/Pos/Block/Lrc.hs @@ -28,9 +28,10 @@ import UnliftIO (MonadUnliftIO) import Pos.Block.Logic.Internal (BypassSecurityCheck (..), MonadBlockApply, applyBlocksUnsafe, rollbackBlocksUnsafe) import Pos.Block.Slog.Logic (ShouldCallBListener (..)) -import Pos.Core (Coin, EpochIndex, EpochOrSlot (..), SharedSeed, - StakeholderId, blkSecurityParam, crucialSlot, epochIndexL, - epochSlots, getEpochOrSlot) +import Pos.Core (Coin, EpochIndex, EpochOrSlot (..), + ProtocolConstants (..), SharedSeed, SlotCount, + StakeholderId, crucialSlot, epochIndexL, getEpochOrSlot, + pcBlkSecurityParam, pcEpochSlots) import Pos.Core.Chrono (NE, NewestFirst (..), toOldestFirst) import Pos.Crypto (ProtocolMagic) import qualified Pos.DB.Block.Load as DB @@ -86,9 +87,10 @@ lrcSingleShot :: forall ctx m . (LrcModeFull ctx m, HasMisbehaviorMetrics ctx) => ProtocolMagic + -> ProtocolConstants -> EpochIndex -> m () -lrcSingleShot pm epoch = do +lrcSingleShot pm pc epoch = do lock <- views (lensOf @LrcContext) lcLrcSync logDebug $ sformat ("lrcSingleShot is trying to acquire LRC lock, the epoch is " @@ -114,7 +116,7 @@ lrcSingleShot pm epoch = do , expectedRichmenComp) when need $ do logInfo "LRC is starting actual computation" - lrcDo pm epoch filteredConsumers + lrcDo pm pc epoch filteredConsumers logInfo "LRC has finished actual computation" putEpoch epoch logInfo ("LRC has updated LRC DB" <> for_thEpochMsg) @@ -143,10 +145,11 @@ lrcDo , HasMisbehaviorMetrics ctx ) => ProtocolMagic + -> ProtocolConstants -> EpochIndex -> [LrcConsumer m] -> m () -lrcDo pm epoch consumers = do +lrcDo pm pc epoch consumers = do blundsUpToGenesis <- DB.loadBlundsFromTipWhile upToGenesis -- If there are blocks from 'epoch' it means that we somehow accepted them -- before running LRC for 'epoch'. It's very bad. @@ -180,18 +183,18 @@ lrcDo pm epoch consumers = do issuersComputationDo epoch richmenComputationDo epoch consumers DB.sanityCheckDB - leadersComputationDo epoch seed + leadersComputationDo (pcEpochSlots pc) epoch seed where atLeastKNewestFirst :: forall a. NewestFirst [] a -> Maybe (NewestFirst NE a) atLeastKNewestFirst l = - if length l >= fromIntegral blkSecurityParam + if length l >= pcK pc then coerce (nonEmpty @a) l else Nothing - applyBack blunds = applyBlocksUnsafe pm scb blunds Nothing + applyBack blunds = applyBlocksUnsafe pm pc scb blunds Nothing upToGenesis b = b ^. epochIndexL >= epoch whileAfterCrucial b = getEpochOrSlot b > crucial - crucial = EpochOrSlot $ Right $ crucialSlot epoch + crucial = EpochOrSlot $ Right $ crucialSlot (pcBlkSecurityParam pc) epoch bsc = -- LRC rollbacks temporarily to examine the state of the DB at the -- time of the crucial slot. The crucial slot may be further than 'blkSecurityParam' @@ -203,7 +206,7 @@ lrcDo pm epoch consumers = do -- and outer viewers mustn't know about it. ShouldCallBListener False withBlocksRolledBack blunds = - bracket_ (rollbackBlocksUnsafe pm bsc scb blunds) + bracket_ (rollbackBlocksUnsafe pm pc bsc scb blunds) (applyBack (toOldestFirst blunds)) issuersComputationDo :: forall ctx m . LrcMode ctx m => EpochIndex -> m () @@ -222,15 +225,16 @@ issuersComputationDo epochId = do Just stake -> pure $ HM.insert id stake hm leadersComputationDo :: LrcMode ctx m - => EpochIndex + => SlotCount + -> EpochIndex -> SharedSeed -> m () -leadersComputationDo epochId seed = +leadersComputationDo epochSlots epochId seed = unlessM (LrcDB.hasLeaders epochId) $ do totalStake <- GS.getRealTotalStake leaders <- runConduitRes $ GS.stakeSource .| followTheSatoshiM epochSlots seed totalStake - LrcDB.putLeadersForEpoch epochId leaders + LrcDB.putLeadersForEpoch epochSlots epochId leaders -------------------------------------------------------------------------------- -- Richmen diff --git a/block/src/Pos/Block/Network/Logic.hs b/block/src/Pos/Block/Network/Logic.hs index 74f76c7598a..618d5c52445 100644 --- a/block/src/Pos/Block/Network/Logic.hs +++ b/block/src/Pos/Block/Network/Logic.hs @@ -37,8 +37,9 @@ import qualified Pos.Block.Logic as L import Pos.Block.RetrievalQueue (BlockRetrievalQueue, BlockRetrievalQueueTag, BlockRetrievalTask (..)) import Pos.Block.Types (Blund, LastKnownHeaderTag) -import Pos.Core (HasHeaderHash (..), HeaderHash, gbHeader, - headerHashG, isMoreDifficult, prevBlockL) +import Pos.Core (HasHeaderHash (..), HeaderHash, ProtocolConstants, + SlotCount, gbHeader, headerHashG, isMoreDifficult, + pcEpochSlots, prevBlockL) import Pos.Core.Block (Block, BlockHeader, blockHeader) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), _NewestFirst, _OldestFirst) @@ -99,50 +100,51 @@ instance Exception BlockNetLogicException where -- progress and 'ncRecoveryHeader' is full, we'll be requesting blocks anyway -- and until we're finished we shouldn't be asking for new blocks. triggerRecovery - :: ( BlockWorkMode ctx m - ) - => ProtocolMagic -> Diffusion m -> m () -triggerRecovery pm diffusion = unlessM recoveryInProgress $ do - logDebug "Recovery triggered, requesting tips from neighbors" - -- The 'catch' here is for an exception when trying to enqueue the request. - -- In 'requestTipsAndProcess', IO exceptions are caught, for each - -- individual request per-peer. Those are not re-thrown. - void requestTipsAndProcess `catch` - \(e :: SomeException) -> do - logDebug ("Error happened in triggerRecovery: " <> show e) - throwM e - logDebug "Finished requesting tips for recovery" + :: BlockWorkMode ctx m => ProtocolMagic -> SlotCount -> Diffusion m -> m () +triggerRecovery pm epochSlots diffusion = + unlessM (recoveryInProgress epochSlots) $ do + logDebug "Recovery triggered, requesting tips from neighbors" + -- The 'catch' here is for an exception when trying to enqueue the + -- request. In 'requestTipsAndProcess', IO exceptions are caught, for + -- each individual request per-peer. Those are not re-thrown. + void requestTipsAndProcess `catch` \(e :: SomeException) -> do + logDebug ("Error happened in triggerRecovery: " <> show e) + throwM e + logDebug "Finished requesting tips for recovery" where requestTipsAndProcess = do requestsMap <- Diffusion.requestTip diffusion - forConcurrently (M.toList requestsMap) $ \it@(nodeId, _) -> waitAndProcessOne it `catch` + forConcurrently (M.toList requestsMap) $ \it@(nodeId, _) -> -- Catch and squelch IOExceptions so that one failed request to one -- particlar peer does not stop the others. - \(e :: IOException) -> - logDebug $ sformat ("Error requesting tip from "%shown%": "%shown) nodeId e + waitAndProcessOne it `catch` \(e :: IOException) -> + logDebug $ sformat + ("Error requesting tip from " % shown % ": " % shown) + nodeId + e waitAndProcessOne (nodeId, mbh) = do -- 'mbh' is an 'm' term that returns when the header has been -- downloaded. bh <- mbh -- I know, it's not unsolicited. TODO rename. - handleUnsolicitedHeader pm bh nodeId + handleUnsolicitedHeader pm epochSlots bh nodeId ---------------------------------------------------------------------------- -- Headers processing ---------------------------------------------------------------------------- handleUnsolicitedHeader - :: ( BlockWorkMode ctx m - ) + :: BlockWorkMode ctx m => ProtocolMagic + -> SlotCount -> BlockHeader -> NodeId -> m () -handleUnsolicitedHeader pm header nodeId = do +handleUnsolicitedHeader pm epochSlots header nodeId = do logDebug $ sformat ("handleUnsolicitedHeader: single header was propagated, processing:\n" %build) header - classificationRes <- classifyNewHeader pm header + classificationRes <- classifyNewHeader pm epochSlots header -- TODO: should we set 'To' hash to hash of header or leave it unlimited? case classificationRes of CHContinues -> do @@ -222,15 +224,14 @@ updateLastKnownHeader lastKnownH header = do -- | Carefully apply blocks that came from the network. handleBlocks - :: forall ctx m . - ( BlockWorkMode ctx m - , HasMisbehaviorMetrics ctx - ) + :: forall ctx m + . (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) => ProtocolMagic + -> ProtocolConstants -> OldestFirst NE Block -> Diffusion m -> m () -handleBlocks pm blocks diffusion = do +handleBlocks pm pc blocks diffusion = do logDebug "handleBlocks: processing" inAssertMode $ logInfo $ sformat ("Processing sequence of blocks: " % buildListBounds % "...") $ @@ -248,20 +249,19 @@ handleBlocks pm blocks diffusion = do logDebug $ sformat ("Handling block w/ LCA, which is "%shortHashF) lcaHash -- Head blund in result is the youngest one. toRollback <- DB.loadBlundsFromTipWhile $ \blk -> headerHash blk /= lcaHash - maybe (applyWithoutRollback pm diffusion blocks) - (applyWithRollback pm diffusion blocks lcaHash) + maybe (applyWithoutRollback pm pc diffusion blocks) + (applyWithRollback pm pc diffusion blocks lcaHash) (_NewestFirst nonEmpty toRollback) applyWithoutRollback - :: forall ctx m. - ( BlockWorkMode ctx m - , HasMisbehaviorMetrics ctx - ) + :: forall ctx m + . (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) => ProtocolMagic + -> ProtocolConstants -> Diffusion m -> OldestFirst NE Block -> m () -applyWithoutRollback pm diffusion blocks = do +applyWithoutRollback pm pc diffusion blocks = do logInfo . sformat ("Trying to apply blocks w/o rollback. " % multilineBounds 6) . getOldestFirst . map (view blockHeader) $ blocks modifyStateLock HighPriority ApplyBlock applyWithoutRollbackDo >>= \case @@ -281,7 +281,7 @@ applyWithoutRollback pm diffusion blocks = do & map (view blockHeader) applied = NE.fromList $ getOldestFirst prefix <> one (toRelay ^. blockHeader) - relayBlock diffusion toRelay + relayBlock (pcEpochSlots pc) diffusion toRelay logInfo $ blocksAppliedMsg applied for_ blocks $ jsonLog . jlAdoptedBlock where @@ -290,67 +290,82 @@ applyWithoutRollback pm diffusion blocks = do :: HeaderHash -> m (HeaderHash, Either ApplyBlocksException HeaderHash) applyWithoutRollbackDo curTip = do logInfo "Verifying and applying blocks..." - res <- verifyAndApplyBlocks pm False blocks + res <- verifyAndApplyBlocks pm pc False blocks logInfo "Verifying and applying blocks done" let newTip = either (const curTip) identity res pure (newTip, res) applyWithRollback - :: ( BlockWorkMode ctx m - , HasMisbehaviorMetrics ctx - ) + :: (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) => ProtocolMagic + -> ProtocolConstants -> Diffusion m -> OldestFirst NE Block -> HeaderHash -> NewestFirst NE Blund -> m () -applyWithRollback pm diffusion toApply lca toRollback = do - logInfo . sformat ("Trying to apply blocks w/o rollback. " % multilineBounds 6) - . getOldestFirst . map (view blockHeader) $ toApply - logInfo $ sformat ("Blocks to rollback "%listJson) toRollbackHashes +applyWithRollback pm pc diffusion toApply lca toRollback = do + logInfo + . sformat ("Trying to apply blocks w/o rollback. " % multilineBounds 6) + . getOldestFirst + . map (view blockHeader) + $ toApply + logInfo $ sformat ("Blocks to rollback " % listJson) toRollbackHashes res <- modifyStateLock HighPriority ApplyBlockWithRollback $ \curTip -> do - res <- L.applyWithRollback pm toRollback toApplyAfterLca + res <- L.applyWithRollback pm pc toRollback toApplyAfterLca pure (either (const curTip) identity res, res) case res of Left (pretty -> err) -> logWarning $ "Couldn't apply blocks with rollback: " <> err Right newTip -> do logDebug $ sformat - ("Finished applying blocks w/ rollback, relaying new tip: "%shortHashF) + ( "Finished applying blocks w/ rollback, relaying new tip: " + % shortHashF + ) newTip reportRollback logInfo $ blocksRolledBackMsg (getNewestFirst toRollback) logInfo $ blocksAppliedMsg (getOldestFirst toApply) for_ (getOldestFirst toApply) $ jsonLog . jlAdoptedBlock - relayBlock diffusion $ toApply ^. _OldestFirst . _neLast + relayBlock (pcEpochSlots pc) diffusion + $ toApply + ^. _OldestFirst + . _neLast where toRollbackHashes = fmap headerHash toRollback - reportRollback = do + reportRollback = do let rollbackDepth = length toRollback -- Commit rollback value to EKG - whenJustM (view misbehaviorMetrics) $ liftIO . - flip Metrics.set (fromIntegral rollbackDepth) . _mmRollbacks + whenJustM (view misbehaviorMetrics) + $ liftIO + . flip Metrics.set (fromIntegral rollbackDepth) + . _mmRollbacks panicBrokenLca = error "applyWithRollback: nothing after LCA :<" toApplyAfterLca = - OldestFirst $ - fromMaybe panicBrokenLca $ nonEmpty $ - NE.dropWhile ((lca /=) . (^. prevBlockL)) $ - getOldestFirst $ toApply + OldestFirst + $ fromMaybe panicBrokenLca + $ nonEmpty + $ NE.dropWhile ((lca /=) . (^. prevBlockL)) + $ getOldestFirst + $ toApply relayBlock - :: forall ctx m. - (BlockWorkMode ctx m) - => Diffusion m -> Block -> m () -relayBlock _ (Left _) = logDebug "Not relaying Genesis block" -relayBlock diffusion (Right mainBlk) = do - recoveryInProgress >>= \case - True -> logDebug "Not relaying block in recovery mode" + :: forall ctx m + . BlockWorkMode ctx m + => SlotCount + -> Diffusion m + -> Block + -> m () +relayBlock _ _ (Left _) = logDebug "Not relaying Genesis block" +relayBlock epochSlots diffusion (Right mainBlk) = do + recoveryInProgress epochSlots >>= \case + True -> logDebug "Not relaying block in recovery mode" False -> do - logDebug $ sformat ("Calling announceBlock for "%shortHashF%".") - (mainBlk ^. gbHeader . headerHashG) + logDebug $ sformat + ("Calling announceBlock for " % shortHashF % ".") + (mainBlk ^. gbHeader . headerHashG) void $ Diffusion.announceBlockHeader diffusion $ mainBlk ^. gbHeader ---------------------------------------------------------------------------- @@ -359,12 +374,12 @@ relayBlock diffusion (Right mainBlk) = do -- TODO: ban node for it! onFailedVerifyBlocks - :: forall ctx m. - (BlockWorkMode ctx m) - => NonEmpty Block -> Text -> m () + :: forall ctx m . BlockWorkMode ctx m => NonEmpty Block -> Text -> m () onFailedVerifyBlocks blocks err = do - logWarning $ sformat ("Failed to verify blocks: "%stext%"\n blocks = "%listJson) - err (fmap headerHash blocks) + logWarning $ sformat + ("Failed to verify blocks: " % stext % "\n blocks = " % listJson) + err + (fmap headerHash blocks) throwM $ DialogUnexpected err blocksAppliedMsg diff --git a/block/src/Pos/Block/Network/Retrieval.hs b/block/src/Pos/Block/Network/Retrieval.hs index 59d8adba352..39068e1a8a2 100644 --- a/block/src/Pos/Block/Network/Retrieval.hs +++ b/block/src/Pos/Block/Network/Retrieval.hs @@ -28,8 +28,9 @@ import Pos.Block.Network.Logic (BlockNetLogicException (..), import Pos.Block.RetrievalQueue (BlockRetrievalQueueTag, BlockRetrievalTask (..)) import Pos.Block.Types (RecoveryHeaderTag) -import Pos.Core (Block, HasHeaderHash (..), HeaderHash, difficultyL, - isMoreDifficult) +import Pos.Core (Block, HasHeaderHash (..), HeaderHash, + ProtocolConstants, SlotCount, difficultyL, + isMoreDifficult, pcBlkSecurityParam, pcEpochSlots) import Pos.Core.Block (BlockHeader) import Pos.Core.Chrono (NE, OldestFirst (..), _OldestFirst) import Pos.Crypto (ProtocolMagic, shortHashF) @@ -56,12 +57,13 @@ import Pos.Util.Util (HasLens (..)) -- If both happen at the same time, 'BlockRetrievalQueue' takes precedence. -- retrievalWorker - :: forall ctx m. - ( BlockWorkMode ctx m - , HasMisbehaviorMetrics ctx - ) - => ProtocolMagic -> Diffusion m -> m () -retrievalWorker pm diffusion = do + :: forall ctx m + . (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) + => ProtocolMagic + -> ProtocolConstants + -> Diffusion m + -> m () +retrievalWorker pm pc diffusion = do logInfo "Starting retrievalWorker loop" mainLoop where @@ -111,9 +113,9 @@ retrievalWorker pm diffusion = do handleContinues nodeId header = do let hHash = headerHash header logDebug $ "handleContinues: " <> pretty hHash - classifyNewHeader pm header >>= \case + classifyNewHeader pm (pcEpochSlots pc) header >>= \case CHContinues -> - void $ getProcessBlocks pm diffusion nodeId (headerHash header) [hHash] + void $ getProcessBlocks pm pc diffusion nodeId (headerHash header) [hHash] res -> logDebug $ "processContHeader: expected header to " <> "be continuation, but it's " <> show res @@ -123,7 +125,7 @@ retrievalWorker pm diffusion = do -- enter recovery mode. handleAlternative nodeId header = do logDebug $ "handleAlternative: " <> pretty (headerHash header) - classifyNewHeader pm header >>= \case + classifyNewHeader pm (pcEpochSlots pc) header >>= \case CHInvalid _ -> logError "handleAlternative: invalid header got into retrievalWorker queue" CHUseless _ -> @@ -155,7 +157,7 @@ retrievalWorker pm diffusion = do reportOrLogW (sformat ("handleRecoveryE: error handling nodeId="%build%", header="%build%": ") nodeId (headerHash rHeader)) e - dropRecoveryHeaderAndRepeat pm diffusion nodeId + dropRecoveryHeaderAndRepeat pm (pcEpochSlots pc) diffusion nodeId -- Recovery handling. We assume that header in the recovery variable is -- appropriate and just query headers/blocks. @@ -168,8 +170,8 @@ retrievalWorker pm diffusion = do throwM $ DialogUnexpected $ "handleRecovery: recovery header is " <> "already present in db" logDebug "handleRecovery: fetching blocks" - checkpoints <- toList <$> getHeadersOlderExp Nothing - void $ streamProcessBlocks pm diffusion nodeId (headerHash rHeader) checkpoints + checkpoints <- toList <$> getHeadersOlderExp (pcBlkSecurityParam pc) Nothing + void $ streamProcessBlocks pm pc diffusion nodeId (headerHash rHeader) checkpoints ---------------------------------------------------------------------------- -- Entering and exiting recovery mode @@ -255,8 +257,13 @@ dropRecoveryHeader nodeId = do -- | Drops the recovery header and, if it was successful, queries the tips. dropRecoveryHeaderAndRepeat - :: BlockWorkMode ctx m => ProtocolMagic -> Diffusion m -> NodeId -> m () -dropRecoveryHeaderAndRepeat pm diffusion nodeId = do + :: BlockWorkMode ctx m + => ProtocolMagic + -> SlotCount + -> Diffusion m + -> NodeId + -> m () +dropRecoveryHeaderAndRepeat pm epochSlots diffusion nodeId = do kicked <- dropRecoveryHeader nodeId when kicked $ attemptRestartRecovery where @@ -264,7 +271,7 @@ dropRecoveryHeaderAndRepeat pm diffusion nodeId = do logDebug "Attempting to restart recovery" -- FIXME why delay? Why 2 seconds? delay (2 :: Second) - handleAny handleRecoveryTriggerE $ triggerRecovery pm diffusion + handleAny handleRecoveryTriggerE $ triggerRecovery pm epochSlots diffusion logDebug "Attempting to restart recovery over" handleRecoveryTriggerE = -- REPORT:ERROR 'reportOrLogE' somewhere in block retrieval. @@ -274,17 +281,16 @@ dropRecoveryHeaderAndRepeat pm diffusion nodeId = do -- Returns only if blocks were successfully downloaded and -- processed. Throws exception if something goes wrong. getProcessBlocks - :: forall ctx m. - ( BlockWorkMode ctx m - , HasMisbehaviorMetrics ctx - ) + :: forall ctx m + . (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) => ProtocolMagic + -> ProtocolConstants -> Diffusion m -> NodeId -> HeaderHash -> [HeaderHash] -> m () -getProcessBlocks pm diffusion nodeId desired checkpoints = do +getProcessBlocks pm pc diffusion nodeId desired checkpoints = do result <- Diffusion.getBlocks diffusion nodeId desired checkpoints case OldestFirst <$> nonEmpty (getOldestFirst result) of Nothing -> do @@ -297,7 +303,7 @@ getProcessBlocks pm diffusion nodeId desired checkpoints = do logDebug $ sformat ("Retrieved "%int%" blocks") (blocks ^. _OldestFirst . to NE.length) - handleBlocks pm blocks diffusion + handleBlocks pm pc blocks diffusion -- If we've downloaded any block with bigger -- difficulty than ncRecoveryHeader, we're -- gracefully exiting recovery mode. @@ -319,23 +325,22 @@ getProcessBlocks pm diffusion nodeId desired checkpoints = do -- Will fall back to getProcessBlocks if streaming is disabled -- or not supported by peer. streamProcessBlocks - :: forall ctx m. - ( BlockWorkMode ctx m - , HasMisbehaviorMetrics ctx - ) + :: forall ctx m + . (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) => ProtocolMagic + -> ProtocolConstants -> Diffusion m -> NodeId -> HeaderHash -> [HeaderHash] -> m () -streamProcessBlocks pm diffusion nodeId desired checkpoints = do +streamProcessBlocks pm pc diffusion nodeId desired checkpoints = do logInfo "streaming start" r <- Diffusion.streamBlocks diffusion nodeId desired checkpoints (loop 0 []) case r of Nothing -> do logInfo "streaming not supported, reverting to batch mode" - getProcessBlocks pm diffusion nodeId desired checkpoints + getProcessBlocks pm pc diffusion nodeId desired checkpoints Just _ -> do logInfo "streaming done" return () @@ -364,4 +369,4 @@ streamProcessBlocks pm diffusion nodeId desired checkpoints = do addBlocks [] = return () addBlocks (block : blocks) = - handleBlocks pm (OldestFirst (NE.reverse $ block :| blocks)) diffusion + handleBlocks pm pc (OldestFirst (NE.reverse $ block :| blocks)) diffusion diff --git a/block/src/Pos/Block/Slog/Context.hs b/block/src/Pos/Block/Slog/Context.hs index a51cad1f519..296a4b63219 100644 --- a/block/src/Pos/Block/Slog/Context.hs +++ b/block/src/Pos/Block/Slog/Context.hs @@ -16,7 +16,7 @@ import qualified System.Metrics as Ekg import Pos.Block.Configuration (HasBlockConfiguration, fixedTimeCQSec) import Pos.Block.Slog.Types (HasSlogGState (..), LastBlkSlots, SlogContext (..), SlogGState (..), sgsLastBlkSlots) -import Pos.Core (blkSecurityParam) +import Pos.Core (BlockCount) import Pos.DB.Class (MonadDBRead) import Pos.GState.BlockExtra (getLastSlots) import Pos.Infra.Reporting (MetricMonitorState, mkMetricMonitorState) @@ -29,19 +29,19 @@ mkSlogGState = do return SlogGState {..} -- | Make new 'SlogContext' using data from DB. -mkSlogContext :: - forall m. (MonadIO m, MonadDBRead m, HasBlockConfiguration) - => Ekg.Store +mkSlogContext + :: forall m + . (MonadIO m, MonadDBRead m, HasBlockConfiguration) + => BlockCount + -> Ekg.Store -> m SlogContext -mkSlogContext store = do +mkSlogContext k store = do _scGState <- mkSlogGState let mkMMonitorState :: Text -> m (MetricMonitorState a) mkMMonitorState = flip mkMetricMonitorState store -- Chain quality metrics stuff. - let metricNameK = - sformat ("chain_quality_last_k_("%int%")_blocks_%") - blkSecurityParam + let metricNameK = sformat ("chain_quality_last_k_("%int%")_blocks_%") k let metricNameOverall = "chain_quality_overall_%" let metricNameFixed = sformat ("chain_quality_last_"%int%"_sec_%") diff --git a/block/src/Pos/Block/Slog/Logic.hs b/block/src/Pos/Block/Slog/Logic.hs index e7901d6d859..ae13c361ebf 100644 --- a/block/src/Pos/Block/Slog/Logic.hs +++ b/block/src/Pos/Block/Slog/Logic.hs @@ -36,9 +36,10 @@ import Pos.Block.Logic.Integrity (verifyBlocks) import Pos.Block.Slog.Context (slogGetLastSlots, slogPutLastSlots) import Pos.Block.Slog.Types (HasSlogGState) import Pos.Block.Types (Blund, SlogUndo (..), Undo (..)) -import Pos.Core (BlockVersion (..), FlatSlotId, blkSecurityParam, - difficultyL, epochIndexL, flattenSlotId, headerHash, - headerHashG, prevBlockL) +import Pos.Core (BlockCount, BlockVersion (..), FlatSlotId, + ProtocolConstants (..), difficultyL, epochIndexL, + flattenSlotId, headerHash, headerHashG, kEpochSlots, + pcBlkSecurityParam, pcEpochSlots, prevBlockL) import Pos.Core.Block (Block, genBlockLeaders, mainBlockSlot) import Pos.Core.Chrono (NE, NewestFirst (getNewestFirst), OldestFirst (..), toOldestFirst, _OldestFirst) @@ -129,10 +130,11 @@ type MonadSlogVerify ctx m = slogVerifyBlocks :: MonadSlogVerify ctx m => ProtocolMagic + -> ProtocolConstants -> OldestFirst NE Block -> m (Either Text (OldestFirst NE SlogUndo)) -slogVerifyBlocks pm blocks = runExceptT $ do - curSlot <- getCurrentSlot +slogVerifyBlocks pm pc blocks = runExceptT $ do + curSlot <- getCurrentSlot $ pcEpochSlots pc (adoptedBV, adoptedBVD) <- lift GS.getAdoptedBVFull let dataMustBeKnown = mustDataBeKnown adoptedBV let headEpoch = blocks ^. _Wrapped . _neHead . epochIndexL @@ -155,12 +157,12 @@ slogVerifyBlocks pm blocks = runExceptT $ do let blocksList :: OldestFirst [] Block blocksList = OldestFirst (NE.toList (getOldestFirst blocks)) verResToMonadError formatAllErrors $ - verifyBlocks pm curSlot dataMustBeKnown adoptedBVD leaders blocksList + verifyBlocks pm pc curSlot dataMustBeKnown adoptedBVD leaders blocksList -- Here we need to compute 'SlogUndo'. When we apply a block, -- we can remove one of the last slots stored in 'BlockExtra'. -- This removed slot must be put into 'SlogUndo'. lastSlots <- lift GS.getLastSlots - let toFlatSlot = fmap (flattenSlotId . view mainBlockSlot) . rightToMaybe + let toFlatSlot = fmap (flattenSlotId (pcEpochSlots pc) . view mainBlockSlot) . rightToMaybe -- these slots will be added if we apply all blocks let newSlots = mapMaybe toFlatSlot (toList blocks) let combinedSlots :: OldestFirst [] FlatSlotId @@ -170,7 +172,7 @@ slogVerifyBlocks pm blocks = runExceptT $ do let removedSlots :: OldestFirst [] FlatSlotId removedSlots = combinedSlots & _Wrapped %~ - (take $ length combinedSlots - fromIntegral blkSecurityParam) + (take $ length combinedSlots - pcK pc) -- Note: here we exploit the fact that genesis block can be only 'head'. -- If we have genesis block, then size of 'newSlots' will be less than -- number of blocks we verify. It means that there will definitely @@ -215,10 +217,11 @@ newtype ShouldCallBListener = ShouldCallBListener Bool -- 6. Setting @inMainChain@ flags slogApplyBlocks :: MonadSlogApply ctx m - => ShouldCallBListener + => BlockCount + -> ShouldCallBListener -> OldestFirst NE Blund -> m SomeBatchOp -slogApplyBlocks (ShouldCallBListener callBListener) blunds = do +slogApplyBlocks k (ShouldCallBListener callBListener) blunds = do -- Note: it's important to put blunds first. The invariant is that -- the sequence of blocks corresponding to the tip must exist in -- BlockDB. If program is interrupted after we put blunds and @@ -252,7 +255,7 @@ slogApplyBlocks (ShouldCallBListener callBListener) blunds = do toList $ fmap (GS.SetInMainChain True . view headerHashG . fst) blunds mainBlocks = rights $ toList blocks - newSlots = flattenSlotId . view mainBlockSlot <$> mainBlocks + newSlots = flattenSlotId (kEpochSlots k) . view mainBlockSlot <$> mainBlocks newLastSlots lastSlots = lastSlots & _Wrapped %~ updateLastSlots knownSlotsBatch lastSlots | null newSlots = [] @@ -260,7 +263,7 @@ slogApplyBlocks (ShouldCallBListener callBListener) blunds = do -- Slots are in 'OldestFirst' order. So we put new slots to the -- end and drop old slots from the beginning. updateLastSlots lastSlots = - leaveAtMostN (fromIntegral blkSecurityParam) (lastSlots ++ newSlots) + leaveAtMostN (fromIntegral k) (lastSlots ++ newSlots) leaveAtMostN :: Int -> [a] -> [a] leaveAtMostN n lst = drop (length lst - n) lst blockExtraBatch lastSlots = @@ -283,11 +286,12 @@ newtype BypassSecurityCheck = BypassSecurityCheck Bool -- 5. Removing @inMainChain@ flags slogRollbackBlocks :: MonadSlogApply ctx m - => BypassSecurityCheck -- ^ is rollback for more than k blocks allowed? + => ProtocolConstants + -> BypassSecurityCheck -- ^ is rollback for more than k blocks allowed? -> ShouldCallBListener -> NewestFirst NE Blund -> m SomeBatchOp -slogRollbackBlocks (BypassSecurityCheck bypassSecurity) (ShouldCallBListener callBListener) blunds = do +slogRollbackBlocks pc (BypassSecurityCheck bypassSecurity) (ShouldCallBListener callBListener) blunds = do inAssertMode $ when (isGenesis0 (blocks ^. _Wrapped . _neLast)) $ assertionFailed $ colorize Red "FATAL: we are TRYING TO ROLLBACK 0-TH GENESIS block" @@ -302,12 +306,12 @@ slogRollbackBlocks (BypassSecurityCheck bypassSecurity) (ShouldCallBListener cal -- no underflow from subtraction maxSeenDifficulty >= resultingDifficulty && -- no rollback further than k blocks - maxSeenDifficulty - resultingDifficulty <= fromIntegral blkSecurityParam + maxSeenDifficulty - resultingDifficulty <= fromIntegral (pcBlkSecurityParam pc) unless (bypassSecurity || secure) $ reportFatalError "slogRollbackBlocks: the attempted rollback would \ \lead to a more than 'k' distance between tip and \ \last seen block, which is a security risk. Aborting." - bListenerBatch <- if callBListener then onRollbackBlocks blunds + bListenerBatch <- if callBListener then onRollbackBlocks pc blunds else pure mempty let putTip = SomeBatchOp $ GS.PutTip $ diff --git a/block/src/Pos/Block/Slog/Types.hs b/block/src/Pos/Block/Slog/Types.hs index 2d2d088383f..4faa202513c 100644 --- a/block/src/Pos/Block/Slog/Types.hs +++ b/block/src/Pos/Block/Slog/Types.hs @@ -11,18 +11,17 @@ module Pos.Block.Slog.Types , HasSlogContext (..) , SlogUndo (..) + , buildSlogUndo ) where import Universum import Control.Lens (makeClassy) -import qualified Data.Text.Buildable -import Formatting (bprint) +import Formatting (Format, bprint, later) import System.Metrics.Label (Label) import Pos.Core (ChainDifficulty, EpochIndex, FlatSlotId, - HasProtocolConstants, LocalSlotIndex, slotIdF, - unflattenSlotId) + LocalSlotIndex, SlotCount, slotIdF, unflattenSlotId) import Pos.Core.Chrono (OldestFirst (..)) import Pos.Infra.Reporting.Metrics (MetricMonitorState) @@ -91,7 +90,9 @@ newtype SlogUndo = SlogUndo { getSlogUndo :: Maybe FlatSlotId } deriving (Eq, Show, NFData, Generic) -instance HasProtocolConstants => Buildable SlogUndo where - build (SlogUndo oldSlot) = - "SlogUndo: " <> - maybe "" (bprint slotIdF . unflattenSlotId) oldSlot +buildSlogUndo :: SlotCount -> Format r (SlogUndo -> r) +buildSlogUndo epochSlots = later $ \(SlogUndo oldSlot) -> + "SlogUndo: " + <> maybe "" + (bprint slotIdF . unflattenSlotId epochSlots) + oldSlot diff --git a/block/src/Pos/Block/Types.hs b/block/src/Pos/Block/Types.hs index eed35ec7604..e395b2e1dba 100644 --- a/block/src/Pos/Block/Types.hs +++ b/block/src/Pos/Block/Types.hs @@ -3,6 +3,7 @@ module Pos.Block.Types ( SlogUndo (..) , Undo (..) + , buildUndo , Blund , LastKnownHeader @@ -17,13 +18,11 @@ module Pos.Block.Types import Universum import qualified Control.Concurrent.STM as STM -import qualified Data.Text.Buildable -import Formatting (bprint, build, (%)) +import Formatting (Format, bprint, build, later, (%)) import Serokell.Util.Text (listJson) -import Pos.Block.Slog.Types (SlogUndo (..)) -import Pos.Core (HasConfiguration, HasDifficulty (..), - HasHeaderHash (..)) +import Pos.Block.Slog.Types (SlogUndo (..), buildSlogUndo) +import Pos.Core (HasDifficulty (..), HasHeaderHash (..), SlotCount) import Pos.Core.Block (Block, BlockHeader) import Pos.Core.Txp (TxpUndo) import Pos.Delegation.Types (DlgUndo) @@ -44,14 +43,14 @@ instance NFData Undo -- | Block and its Undo. type Blund = (Block, Undo) -instance HasConfiguration => Buildable Undo where - build Undo{..} = - bprint ("Undo:\n"% - " undoTx: "%listJson%"\n"% - " undoDlg: "%build%"\n"% - " undoUS: "%build%"\n"% - " undoSlog: "%build) - (map (bprint listJson) undoTx) undoDlg undoUS undoSlog +buildUndo :: SlotCount -> Format r (Undo -> r) +buildUndo epochSlots = later $ \Undo{..} -> + bprint ("Undo:\n"% + " undoTx: "%listJson%"\n"% + " undoDlg: "%build%"\n"% + " undoUS: "%build%"\n"% + " undoSlog: "%buildSlogUndo epochSlots) + (map (bprint listJson) undoTx) undoDlg undoUS undoSlog instance HasDifficulty Blund where difficultyL = _1 . difficultyL diff --git a/block/src/Pos/Block/Worker.hs b/block/src/Pos/Block/Worker.hs index 8d16f5f206a..dec18382d04 100644 --- a/block/src/Pos/Block/Worker.hs +++ b/block/src/Pos/Block/Worker.hs @@ -35,12 +35,14 @@ import Pos.Block.Slog (scCQFixedMonitorState, scCQOverallMonitorState, scDifficultyMonitorState, scEpochMonitorState, scGlobalSlotMonitorState, scLocalSlotMonitorState, slogGetLastSlots) -import Pos.Core (BlockVersionData (..), ChainDifficulty, FlatSlotId, - HasProtocolConstants, SlotId (..), Timestamp (Timestamp), - addressHash, blkSecurityParam, difficultyL, - epochOrSlotToSlot, epochSlots, flattenSlotId, gbHeader, - getEpochOrSlot, getOurPublicKey, getSlotIndex, slotIdF, - unflattenSlotId) +import Pos.Core (BlockCount, BlockVersionData (..), ChainDifficulty, + FlatSlotId, ProtocolConstants, SlotCount, SlotId (..), + Timestamp (Timestamp), addressHash, difficultyL, + epochOrSlotToSlot, flattenSlotId, gbHeader, + getEpochOrSlot, getOurPublicKey, getSlotIndex, + kEpochSlots, kSlotSecurityParam, localSlotIndexFromEnum, + localSlotIndexMinBound, pcBlkSecurityParam, pcEpochSlots, + slotIdF, slotIdSucc, unflattenSlotId) import Pos.Core.Chrono (OldestFirst (..)) import Pos.Crypto (ProtocolMagic, ProxySecretKey (pskDelegatePk)) import Pos.DB (gsIsBootstrapEra) @@ -51,8 +53,8 @@ import Pos.Delegation.Types (ProxySKBlockInfo) import Pos.Infra.Diffusion.Types (Diffusion) import qualified Pos.Infra.Diffusion.Types as Diffusion (Diffusion (announceBlockHeader)) -import Pos.Infra.Recovery.Info (getSyncStatus, getSyncStatusK, - needTriggerRecovery, recoveryCommGuard) +import Pos.Infra.Recovery.Info (getSyncStatus, needTriggerRecovery, + recoveryCommGuard) import Pos.Infra.Reporting (HasMisbehaviorMetrics, MetricMonitor (..), MetricMonitorState, noReportMonitor, recordValue, reportOrLogE) @@ -73,36 +75,40 @@ import Pos.Update.DB (getAdoptedBVData) -- | All workers specific to block processing. blkWorkers - :: ( BlockWorkMode ctx m - , HasMisbehaviorMetrics ctx - ) - => ProtocolMagic -> [Diffusion m -> m ()] -blkWorkers pm = - [ blkCreatorWorker pm - , informerWorker - , retrievalWorker pm - , recoveryTriggerWorker pm + :: (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) + => ProtocolMagic + -> ProtocolConstants + -> [Diffusion m -> m ()] +blkWorkers pm pc = + [ blkCreatorWorker pm pc + , informerWorker (pcBlkSecurityParam pc) + , retrievalWorker pm pc + , recoveryTriggerWorker pm (pcBlkSecurityParam pc) ] -informerWorker - :: ( BlockWorkMode ctx m - ) => Diffusion m -> m () -informerWorker = - \_ -> onNewSlot defaultOnNewSlotParams $ \slotId -> - recoveryCommGuard "onNewSlot worker, informerWorker" $ do - tipHeader <- DB.getTipHeader - -- Printe tip header - logDebug $ sformat ("Our tip header: "%build) tipHeader - -- Print the difference between tip slot and current slot. - logHowManySlotsBehind slotId tipHeader - -- Compute and report metrics - metricWorker slotId +informerWorker :: BlockWorkMode ctx m => BlockCount -> Diffusion m -> m () +informerWorker k _ = + onNewSlot epochSlots defaultOnNewSlotParams + $ \slotId -> recoveryCommGuard k "onNewSlot worker, informerWorker" $ do + tipHeader <- DB.getTipHeader + -- Printe tip header + logDebug $ sformat ("Our tip header: " % build) tipHeader + -- Print the difference between tip slot and current slot. + logHowManySlotsBehind slotId tipHeader + -- Compute and report metrics + metricWorker k slotId where + epochSlots = kEpochSlots k logHowManySlotsBehind slotId tipHeader = - let tipSlot = epochOrSlotToSlot (getEpochOrSlot tipHeader) - slotDiff = flattenSlotId slotId - flattenSlotId tipSlot - in logInfo $ sformat ("Difference between current slot and tip slot is: " - %int) slotDiff + let + tipSlot = epochOrSlotToSlot (getEpochOrSlot tipHeader) + slotDiff = + flattenSlotId epochSlots slotId + - flattenSlotId epochSlots tipSlot + in + logInfo $ sformat + ("Difference between current slot and tip slot is: " % int) + slotDiff ---------------------------------------------------------------------------- @@ -110,32 +116,38 @@ informerWorker = ---------------------------------------------------------------------------- blkCreatorWorker - :: ( BlockWorkMode ctx m - , HasMisbehaviorMetrics ctx - ) => ProtocolMagic -> Diffusion m -> m () -blkCreatorWorker pm = - \diffusion -> onNewSlot onsp $ \slotId -> - recoveryCommGuard "onNewSlot worker, blkCreatorWorker" $ - blockCreator pm slotId diffusion `catchAny` onBlockCreatorException + :: (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) + => ProtocolMagic + -> ProtocolConstants + -> Diffusion m + -> m () +blkCreatorWorker pm pc diffusion = + onNewSlot (pcEpochSlots pc) onsp $ \slotId -> + recoveryCommGuard (pcBlkSecurityParam pc) + "onNewSlot worker, blkCreatorWorker" + $ blockCreator pm pc slotId diffusion + `catchAny` onBlockCreatorException where onBlockCreatorException = reportOrLogE "blockCreator failed: " onsp :: OnNewSlotParams - onsp = - defaultOnNewSlotParams - {onspTerminationPolicy = NewSlotTerminationPolicy "block creator"} + onsp = defaultOnNewSlotParams + { onspTerminationPolicy = NewSlotTerminationPolicy "block creator" + } blockCreator - :: ( BlockWorkMode ctx m - , HasMisbehaviorMetrics ctx - ) - => ProtocolMagic -> SlotId -> Diffusion m -> m () -blockCreator pm (slotId@SlotId {..}) diffusion = do + :: (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) + => ProtocolMagic + -> ProtocolConstants + -> SlotId + -> Diffusion m + -> m () +blockCreator pm pc (slotId@SlotId {..}) diffusion = do -- First of all we create genesis block if necessary. - mGenBlock <- createGenesisBlockAndApply pm siEpoch + mGenBlock <- createGenesisBlockAndApply pm pc siEpoch whenJust mGenBlock $ \createdBlk -> do logInfo $ sformat ("Created genesis block:\n" %build) createdBlk - jsonLog $ jlCreatedBlock (Left createdBlk) + jsonLog $ jlCreatedBlock (pcEpochSlots pc) (Left createdBlk) -- Then we get leaders for current epoch. leadersMaybe <- LrcDB.getLeadersForEpoch siEpoch @@ -152,8 +164,8 @@ blockCreator pm (slotId@SlotId {..}) diffusion = do where onNoLeader = logError "Couldn't find a leader for current slot among known ones" - logOnEpochFS = if siSlot == minBound then logInfoS else logDebugS - logOnEpochF = if siSlot == minBound then logInfo else logDebug + logOnEpochFS = if siSlot == localSlotIndexMinBound then logInfoS else logDebugS + logOnEpochF = if siSlot == localSlotIndexMinBound then logInfo else logDebug onKnownLeader leaders leader = do ourPk <- getOurPublicKey let ourPkHash = addressHash ourPk @@ -168,7 +180,7 @@ blockCreator pm (slotId@SlotId {..}) diffusion = do dropAround p s = take (2*s + 1) . drop (max 0 (p - s)) strLeaders = map (bprint pairF) (enumerate @Int (toList leaders)) logDebug $ sformat ("Trimmed leaders: "%listJson) - $ dropAround (fromEnum siSlot) 10 strLeaders + $ dropAround (localSlotIndexFromEnum siSlot) 10 strLeaders ourHeavyPsk <- getPskByIssuer (Left ourPk) let heavyWeAreIssuer = isJust ourHeavyPsk @@ -184,21 +196,21 @@ blockCreator pm (slotId@SlotId {..}) diffusion = do "delegated by heavy psk: "%build) ourHeavyPsk | weAreLeader -> - onNewSlotWhenLeader pm slotId Nothing diffusion + onNewSlotWhenLeader pm pc slotId Nothing diffusion | heavyWeAreDelegate -> let pske = swap <$> dlgTransM - in onNewSlotWhenLeader pm slotId pske diffusion + in onNewSlotWhenLeader pm pc slotId pske diffusion | otherwise -> pass onNewSlotWhenLeader - :: ( BlockWorkMode ctx m - ) + :: BlockWorkMode ctx m => ProtocolMagic + -> ProtocolConstants -> SlotId -> ProxySKBlockInfo -> Diffusion m -> m () -onNewSlotWhenLeader pm slotId pske diffusion = do +onNewSlotWhenLeader pm pc slotId pske diffusion = do let logReason = sformat ("I have a right to create a block for the slot "%slotIdF%" ") slotId @@ -206,7 +218,7 @@ onNewSlotWhenLeader pm slotId pske diffusion = do logCert (psk,_) = sformat ("using heavyweight proxy signature key "%build%", will do it soon") psk logInfoS $ logReason <> maybe logLeader logCert pske - nextSlotStart <- getSlotStartEmpatically (succ slotId) + nextSlotStart <- getSlotStartEmpatically (slotIdSucc (pcEpochSlots pc) slotId) currentTime <- currentTimeSlotting let timeToCreate = max currentTime (nextSlotStart - Timestamp networkDiameter) @@ -218,13 +230,13 @@ onNewSlotWhenLeader pm slotId pske diffusion = do where onNewSlotWhenLeaderDo = do logInfoS "It's time to create a block for current slot" - createdBlock <- createMainBlockAndApply pm slotId pske + createdBlock <- createMainBlockAndApply pm pc slotId pske either whenNotCreated whenCreated createdBlock logInfoS "onNewSlotWhenLeader: done" whenCreated createdBlk = do logInfoS $ sformat ("Created a new block:\n" %build) createdBlk - jsonLog $ jlCreatedBlock (Right createdBlk) + jsonLog $ jlCreatedBlock (pcEpochSlots pc) (Right createdBlk) void $ Diffusion.announceBlockHeader diffusion $ createdBlk ^. gbHeader whenNotCreated = logWarningS . (mappend "I couldn't create a new block: ") @@ -233,21 +245,24 @@ onNewSlotWhenLeader pm slotId pske diffusion = do ---------------------------------------------------------------------------- recoveryTriggerWorker - :: forall ctx m. - ( BlockWorkMode ctx m - ) - => ProtocolMagic -> Diffusion m -> m () -recoveryTriggerWorker pm diffusion = do + :: forall ctx m + . BlockWorkMode ctx m + => ProtocolMagic + -> BlockCount + -> Diffusion m + -> m () +recoveryTriggerWorker pm k diffusion = do -- Initial heuristic delay is needed (the system takes some time -- to initialize). -- TBD why 3 seconds? Why delay at all? Come on, we can do better. delay (3 :: Second) repeatOnInterval $ do - doTrigger <- needTriggerRecovery <$> getSyncStatusK + doTrigger <- needTriggerRecovery + <$> getSyncStatus epochSlots (kSlotSecurityParam k) when doTrigger $ do logInfo "Triggering recovery because we need it" - triggerRecovery pm diffusion + triggerRecovery pm epochSlots diffusion -- Sometimes we want to trigger recovery just in case. Maybe -- we're just 5 slots late, but nobody wants to send us @@ -255,14 +270,14 @@ recoveryTriggerWorker pm diffusion = do -- guarantees that node will get updates on time. So we -- sometimes ask for tips even if we're in relatively safe -- situation. - (d :: Double) <- liftIO $ randomRIO (0,1) + (d :: Double) <- liftIO $ randomRIO (0, 1) -- P = 0.004 ~ every 250th time (250 seconds ~ every 4.2 minutes) let triggerSafety = not doTrigger && d < 0.004 when triggerSafety $ do logInfo "Checking if we need recovery as a safety measure" - whenM (needTriggerRecovery <$> getSyncStatus 5) $ do + whenM (needTriggerRecovery <$> getSyncStatus epochSlots 5) $ do logInfo "Triggering recovery as a safety measure" - triggerRecovery pm diffusion + triggerRecovery pm epochSlots diffusion -- We don't want to ask for tips too frequently. -- E.g. there may be a tip processing mistake so that we @@ -272,6 +287,7 @@ recoveryTriggerWorker pm diffusion = do -- will minimize risks and network load. when (doTrigger || triggerSafety) $ delay (20 :: Second) where + epochSlots = kEpochSlots k repeatOnInterval action = void $ do delay (1 :: Second) -- REPORT:ERROR 'reportOrLogE' in recovery trigger worker @@ -292,14 +308,12 @@ recoveryTriggerWorker pm diffusion = do -- warnings when this assumption is close to being violated. -- -- Apart from chain quality check we also record some generally useful values. -metricWorker - :: BlockWorkMode ctx m - => SlotId -> m () -metricWorker curSlot = do +metricWorker :: BlockWorkMode ctx m => BlockCount -> SlotId -> m () +metricWorker k curSlot = do OldestFirst lastSlots <- slogGetLastSlots reportTotalBlocks - reportSlottingData curSlot - reportCrucialValues + reportSlottingData (kEpochSlots k) curSlot + reportCrucialValues k -- If total number of blocks is less than `blkSecurityParam' we do -- nothing with regards to chain quality for two reasons: -- 1. Usually after we deploy cluster we monitor it manually for a while. @@ -308,8 +322,8 @@ metricWorker curSlot = do case nonEmpty lastSlots of Nothing -> pass Just slotsNE - | length slotsNE < fromIntegral blkSecurityParam -> pass - | otherwise -> chainQualityChecker curSlot (NE.head slotsNE) + | length slotsNE < fromIntegral k -> pass + | otherwise -> chainQualityChecker k curSlot (NE.head slotsNE) ---------------------------------------------------------------------------- -- -- General metrics @@ -328,8 +342,8 @@ difficultyMonitor :: MetricMonitorState ChainDifficulty -> MetricMonitor ChainDifficulty difficultyMonitor = noReportMonitor fromIntegral Nothing -reportSlottingData :: BlockWorkMode ctx m => SlotId -> m () -reportSlottingData slotId = do +reportSlottingData :: BlockWorkMode ctx m => SlotCount -> SlotId -> m () +reportSlottingData epochSlots slotId = do -- epoch let epoch = siEpoch slotId epochMonitor <- @@ -342,20 +356,19 @@ reportSlottingData slotId = do view scLocalSlotMonitorState recordValue localSlotMonitor localSlot -- global slot - let globalSlot = flattenSlotId slotId + let globalSlot = flattenSlotId epochSlots slotId globalSlotMonitor <- noReportMonitor fromIntegral Nothing <$> view scGlobalSlotMonitorState recordValue globalSlotMonitor globalSlot -reportCrucialValues :: BlockWorkMode ctx m => m () -reportCrucialValues = do +reportCrucialValues :: BlockWorkMode ctx m => BlockCount -> m () +reportCrucialValues k = do label <- view scCrucialValuesLabel BlockVersionData {..} <- getAdoptedBVData let slotDur = bvdSlotDuration - let epochDur = fromIntegral epochSlots * slotDur - let crucialValuesText = - sformat crucialValuesFmt slotDur epochDur blkSecurityParam + let epochDur = fromIntegral (kEpochSlots k) * slotDur + let crucialValuesText = sformat crucialValuesFmt slotDur epochDur k liftIO $ Label.set label crucialValuesText where crucialValuesFmt = @@ -365,33 +378,32 @@ reportCrucialValues = do -- -- Chain quality ---------------------------------------------------------------------------- -chainQualityChecker :: - ( BlockWorkMode ctx m - ) - => SlotId - -> FlatSlotId - -> m () -chainQualityChecker curSlot kThSlot = do +chainQualityChecker + :: BlockWorkMode ctx m => BlockCount -> SlotId -> FlatSlotId -> m () +chainQualityChecker k curSlot kThSlot = do logDebug $ sformat ("Block with depth 'k' ("%int% ") was created during slot "%slotIdF) - blkSecurityParam (unflattenSlotId kThSlot) - let curFlatSlot = flattenSlotId curSlot + k (unflattenSlotId epochSlots kThSlot) + let curFlatSlot = flattenSlotId epochSlots curSlot isBootstrapEra <- gsIsBootstrapEra (siEpoch curSlot) monitorStateK <- view scCQkMonitorState - let monitorK = cqkMetricMonitor monitorStateK isBootstrapEra + let monitorK = cqkMetricMonitor k monitorStateK isBootstrapEra monitorOverall <- cqOverallMetricMonitor <$> view scCQOverallMonitorState monitorFixed <- cqFixedMetricMonitor <$> view scCQFixedMonitorState - whenJustM (calcChainQualityM curFlatSlot) (recordValue monitorK) - whenJustM calcOverallChainQuality $ recordValue monitorOverall - whenJustM calcChainQualityFixedTime $ recordValue monitorFixed + whenJustM (calcChainQualityM k curFlatSlot) (recordValue monitorK) + whenJustM (calcOverallChainQuality epochSlots) $ recordValue monitorOverall + whenJustM (calcChainQualityFixedTime epochSlots) $ recordValue monitorFixed + where + epochSlots = kEpochSlots k -- Monitor for chain quality for last k blocks. -cqkMetricMonitor :: - ( HasBlockConfiguration, HasProtocolConstants ) - => MetricMonitorState Double +cqkMetricMonitor + :: HasBlockConfiguration + => BlockCount + -> MetricMonitorState Double -> Bool -> MetricMonitor Double -cqkMetricMonitor st isBootstrapEra = +cqkMetricMonitor k st isBootstrapEra = MetricMonitor { mmState = st , mmReportMisbehaviour = classifier @@ -420,7 +432,7 @@ cqkMetricMonitor st isBootstrapEra = | otherwise = nonCriticalCQ -- Can be used to insert the value of 'blkSecurityParam' into a 'Format'. kFormat :: Format r r - kFormat = now (bprint int blkSecurityParam) + kFormat = now (bprint int k) cqOverallMetricMonitor :: MetricMonitorState Double -> MetricMonitor Double cqOverallMetricMonitor = noReportMonitor convertCQ (Just debugFormat) diff --git a/block/src/Pos/GState/BlockExtra.hs b/block/src/Pos/GState/BlockExtra.hs index 92f955a446c..277ebc5c044 100644 --- a/block/src/Pos/GState/BlockExtra.hs +++ b/block/src/Pos/GState/BlockExtra.hs @@ -10,6 +10,7 @@ module Pos.GState.BlockExtra , getLastSlots , getFirstGenesisBlockHash , BlockExtraOp (..) + , buildBlockExtraOp , foldlUpWhileM , loadHashesUpWhile , loadHeadersUpWhile @@ -20,17 +21,16 @@ module Pos.GState.BlockExtra import Universum hiding (init) -import qualified Data.Text.Buildable import qualified Database.RocksDB as Rocks -import Formatting (bprint, build, (%)) +import Formatting (Format, bprint, build, later, (%)) import Pipes (Producer, yield) import Serokell.Util.Text (listJson) import Pos.Binary.Class (serialize') import Pos.Block.Slog.Types (LastBlkSlots, noLastBlkSlots) import Pos.Core (FlatSlotId, HasCoreConfiguration, HasHeaderHash, - HasProtocolConstants, HeaderHash, genesisHash, headerHash, - slotIdF, unflattenSlotId) + HeaderHash, SlotCount, genesisHash, headerHash, slotIdF, + unflattenSlotId) import Pos.Core.Block (Block, BlockHeader) import Pos.Core.Chrono (OldestFirst (..)) import Pos.Crypto (shortHashF) @@ -87,16 +87,18 @@ data BlockExtraOp -- ^ Updates list of slots for last blocks. deriving (Show) -instance HasProtocolConstants => Buildable BlockExtraOp where - build (AddForwardLink from to) = +buildBlockExtraOp :: SlotCount -> Format r (BlockExtraOp -> r) +buildBlockExtraOp epochSlots = later build' + where + build' (AddForwardLink from to) = bprint ("AddForwardLink from "%shortHashF%" to "%shortHashF) from to - build (RemoveForwardLink from) = + build' (RemoveForwardLink from) = bprint ("RemoveForwardLink from "%shortHashF) from - build (SetInMainChain flag h) = + build' (SetInMainChain flag h) = bprint ("SetInMainChain for "%shortHashF%": "%build) h flag - build (SetLastSlots slots) = + build' (SetLastSlots slots) = bprint ("SetLastSlots: "%listJson) - (map (bprint slotIdF . unflattenSlotId) slots) + (map (bprint slotIdF . unflattenSlotId epochSlots) slots) instance HasCoreConfiguration => RocksBatchOp BlockExtraOp where toBatchOp (AddForwardLink from to) = diff --git a/block/test/Test/Pos/Block/Arbitrary.hs b/block/test/Test/Pos/Block/Arbitrary.hs index 09fce2ba917..f2da7ee31f8 100644 --- a/block/test/Test/Pos/Block/Arbitrary.hs +++ b/block/test/Test/Pos/Block/Arbitrary.hs @@ -35,8 +35,9 @@ import Pos.Binary.Class (biSize) import qualified Pos.Block.Logic.Integrity as T import Pos.Block.Slog (SlogUndo) import Pos.Block.Types (Undo (..)) -import Pos.Core (GenesisHash (..), HasGenesisHash, - HasProtocolConstants, HeaderHash, epochSlots, genesisHash) +import Pos.Core (GenesisHash (..), HasGenesisHash, HeaderHash, + genesisHash, localSlotIndexMaxBound, + localSlotIndexMinBound) import qualified Pos.Core as Core import qualified Pos.Core.Block as T import Pos.Crypto (ProtocolMagic, PublicKey, SecretKey, createPsk, @@ -44,6 +45,7 @@ import Pos.Crypto (ProtocolMagic, PublicKey, SecretKey, createPsk, import Pos.Data.Attributes (areAttributesKnown) import Test.Pos.Core.Arbitrary (genSlotId) +import Test.Pos.Core.Dummy (dummyEpochSlots) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Delegation.Arbitrary (genDlgPayload) import Test.Pos.Txp.Arbitrary (genTxPayload) @@ -57,11 +59,11 @@ newtype BodyDependsOnSlot b = BodyDependsOnSlot -- Arbitrary instances for Blockchain related types ------------------------------------------------------------------------------------------ -instance HasProtocolConstants => Arbitrary T.BlockHeader where +instance Arbitrary T.BlockHeader where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary T.BlockSignature where +instance Arbitrary T.BlockSignature where arbitrary = genericArbitrary shrink = genericShrink @@ -96,10 +98,7 @@ instance Arbitrary T.GenesisBody where arbitrary = genericArbitrary shrink = genericShrink -instance ( HasProtocolConstants - , HasGenesisHash - ) => - Arbitrary T.GenesisBlock where +instance HasGenesisHash => Arbitrary T.GenesisBlock where arbitrary = T.mkGenesisBlock dummyProtocolMagic <$> (maybe (Left (GenesisHash genesisHash)) Right <$> arbitrary) <*> arbitrary @@ -113,26 +112,25 @@ instance ( HasProtocolConstants -- | Generate a 'MainBlockHeader' given a parent hash, difficulty and body. genMainBlockHeader :: ProtocolMagic - -> Core.ProtocolConstants -> HeaderHash -> Core.ChainDifficulty -> T.MainBody -> Gen T.MainBlockHeader -genMainBlockHeader pm pc prevHash difficulty body = +genMainBlockHeader pm prevHash difficulty body = T.mkMainHeaderExplicit pm <$> pure prevHash <*> pure difficulty - <*> genSlotId pc + <*> genSlotId dummyEpochSlots <*> arbitrary -- SecretKey <*> pure Nothing <*> pure body <*> arbitrary -instance HasProtocolConstants => Arbitrary T.MainBlockHeader where +instance Arbitrary T.MainBlockHeader where arbitrary = do prevHash <- arbitrary difficulty <- arbitrary body <- arbitrary - genMainBlockHeader dummyProtocolMagic Core.protocolConstants prevHash difficulty body + genMainBlockHeader dummyProtocolMagic prevHash difficulty body shrink = genericShrink instance Arbitrary T.MainExtraHeaderData where @@ -151,11 +149,11 @@ instance Arbitrary T.MainProof where shrink (mpTxProof, mpMpcProof, mpProxySKsProof, mpUpdateProof) ] -instance HasProtocolConstants => Arbitrary T.MainConsensusData where +instance Arbitrary T.MainConsensusData where arbitrary = genericArbitrary shrink = genericShrink -instance (HasProtocolConstants) => Arbitrary T.MainToSign where +instance Arbitrary T.MainToSign where arbitrary = genericArbitrary shrink = genericShrink @@ -186,18 +184,16 @@ genMainBlockBody pm epoch = genMainBlockBodyForSlot :: ProtocolMagic - -> Core.ProtocolConstants -> Core.SlotId -> Gen T.MainBody -genMainBlockBodyForSlot pm pc slotId = do +genMainBlockBodyForSlot pm slotId = do txpPayload <- genTxPayload pm - sscPayload <- genSscPayloadForSlot pm pc slotId + sscPayload <- genSscPayloadForSlot pm slotId dlgPayload <- genDlgPayload pm (Core.siEpoch slotId) updPayload <- genUpdatePayload pm pure $ T.MainBody txpPayload sscPayload dlgPayload updPayload -instance HasProtocolConstants => - Arbitrary (BodyDependsOnSlot T.MainBlockchain) where +instance Arbitrary (BodyDependsOnSlot T.MainBlockchain) where arbitrary = pure $ BodyDependsOnSlot $ \slotId -> do txPayload <- arbitrary generator <- genPayloadDependsOnSlot <$> arbitrary @@ -221,13 +217,12 @@ instance Arbitrary T.MainBody where -- You choose the previous header hash. genMainBlock :: ProtocolMagic - -> Core.ProtocolConstants -> HeaderHash -> Core.ChainDifficulty -> Gen T.MainBlock -genMainBlock pm pc prevHash difficulty = do - slot <- genSlotId pc - body <- genMainBlockBodyForSlot pm pc slot +genMainBlock pm prevHash difficulty = do + slot <- genSlotId dummyEpochSlots + body <- genMainBlockBodyForSlot pm slot extraBodyData <- arbitrary extraHeaderData <- T.MainExtraHeaderData <$> arbitrary @@ -241,10 +236,7 @@ genMainBlock pm pc prevHash difficulty = do <*> pure extraHeaderData pure $ T.UnsafeGenericBlock header body extraBodyData -instance ( HasProtocolConstants - , HasGenesisHash - ) => - Arbitrary T.MainBlock where +instance HasGenesisHash => Arbitrary T.MainBlock where arbitrary = do slot <- arbitrary BodyDependsOnSlot {..} <- arbitrary :: Gen (BodyDependsOnSlot T.MainBlockchain) @@ -301,13 +293,7 @@ instance Show BlockHeaderList where -- * if an epoch is `n` slots long, every `n+1`-th block will be of the -- genesis kind. recursiveHeaderGen - :: ( HasProtocolConstants -- Can't remove this unfortunately.... - -- We first have to make generators for - -- other things which are parameterized on - -- the constants and magic etc. so we can use - -- them in here. - ) - => GenesisHash + :: GenesisHash -> Bool -- ^ Whether to create genesis block before creating main block for 0th slot -> [Either SecretKey (SecretKey, SecretKey)] -> [Core.SlotId] @@ -373,18 +359,14 @@ bhlEpochs = 2 -- -- Note that a leader is generated for each slot. -- (Not exactly a leader - see previous comment) -instance ( HasProtocolConstants - , HasGenesisHash - ) => - Arbitrary BlockHeaderList where +instance HasGenesisHash => Arbitrary BlockHeaderList where arbitrary = do - incompleteEpochSize <- choose (1, epochSlots - 1) - let slot = Core.SlotId 0 minBound - generateBHL (GenesisHash genesisHash) True slot (epochSlots * bhlEpochs + incompleteEpochSize) + incompleteEpochSize <- choose (1, dummyEpochSlots - 1) + let slot = Core.SlotId 0 localSlotIndexMinBound + generateBHL (GenesisHash genesisHash) True slot (dummyEpochSlots * bhlEpochs + incompleteEpochSize) generateBHL - :: HasProtocolConstants -- See comment in recursiveHeaderGen - => GenesisHash + :: GenesisHash -> Bool -- ^ Whether to create genesis block before creating main -- block for 0th slot -> Core.SlotId -- ^ Start slot @@ -401,8 +383,8 @@ generateBHL gHash createInitGenesis startSlot slotCount = BHL <$> do let actualLeaders = map (toPublic . either identity (view _1)) leadersList slotIdsRange = take (fromIntegral slotCount) $ - map Core.unflattenSlotId - [Core.flattenSlotId startSlot ..] + map (Core.unflattenSlotId dummyEpochSlots) + [Core.flattenSlotId dummyEpochSlots startSlot ..] (, actualLeaders) <$> recursiveHeaderGen gHash @@ -424,8 +406,7 @@ newtype HeaderAndParams = HAndP -- already been done in the 'Arbitrary' instance of the 'BlockHeaderList' -- type, so it is used here and at most 3 blocks are taken from the generated -- list. -instance (HasProtocolConstants, HasGenesisHash) => - Arbitrary HeaderAndParams where +instance HasGenesisHash => Arbitrary HeaderAndParams where arbitrary = do -- This integer is used as a seed to randomly choose a slot down below seed <- arbitrary :: Gen Int @@ -445,7 +426,7 @@ instance (HasProtocolConstants, HasGenesisHash) => _ -> error "[BlockSpec] the headerchain doesn't have enough headers" -- This binding captures the chosen header's epoch. It is used to -- drop all all leaders of headers from previous epochs. - thisEpochStartIndex = fromIntegral epochSlots * + thisEpochStartIndex = fromIntegral dummyEpochSlots * fromIntegral (header ^. Core.epochIndexL) thisHeadersEpoch = drop thisEpochStartIndex leaders -- A helper function. Given integers 'x' and 'y', it chooses a @@ -470,8 +451,8 @@ instance (HasProtocolConstants, HasGenesisHash) => rndEpoch = betweenXAndY e maxBound rndSlotIdx :: Core.LocalSlotIndex rndSlotIdx = if rndEpoch > e - then betweenXAndY minBound maxBound - else betweenXAndY s maxBound + then betweenXAndY localSlotIndexMinBound (localSlotIndexMaxBound dummyEpochSlots) + else betweenXAndY s (localSlotIndexMaxBound dummyEpochSlots) rndSlot = Core.SlotId rndEpoch rndSlotIdx in Just rndSlot hasUnknownAttributes = @@ -496,6 +477,6 @@ instance Arbitrary SlogUndo where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary Undo where +instance Arbitrary Undo where arbitrary = genericArbitrary shrink = genericShrink diff --git a/block/test/Test/Pos/Block/Arbitrary/Generate.hs b/block/test/Test/Pos/Block/Arbitrary/Generate.hs index 4687f41a842..d188979be7d 100644 --- a/block/test/Test/Pos/Block/Arbitrary/Generate.hs +++ b/block/test/Test/Pos/Block/Arbitrary/Generate.hs @@ -11,8 +11,7 @@ import Test.QuickCheck (arbitrary) import qualified Test.QuickCheck.Gen as QC import qualified Test.QuickCheck.Random as QC -import Pos.Core (HasGenesisHash, HasProtocolConstants, MainBlock, - ProtocolConstants, ProtocolMagic) +import Pos.Core (HasGenesisHash, MainBlock, ProtocolMagic) -- Also brings in the 'Arbitrary' instance for 'MainBlock'. import Test.Pos.Block.Arbitrary (genMainBlock) @@ -20,9 +19,7 @@ import Test.Pos.Block.Arbitrary (genMainBlock) -- | Use 'Arbitrary' instances to generate a 'MainBlock'. -- These require magical configurations. generateMainBlockWithConfiguration - :: ( HasProtocolConstants - , HasGenesisHash - ) + :: HasGenesisHash => Int -- ^ Seed for random generator. -> Int -- ^ Size of the generated value (see QuickCheck docs). -> MainBlock @@ -33,16 +30,14 @@ generateMainBlockWithConfiguration genSeed = QC.unGen arbitrary qcGen -- | Get some arbitrary (probably invalid) 'MainBlock'. The previous header -- hash and difficulty, body, etc. are all chosen at random. generateMainBlock - :: ( ) - => ProtocolMagic - -> ProtocolConstants + :: ProtocolMagic -> Int -> Int -> MainBlock -generateMainBlock pm pc genSeed = QC.unGen generator qcGen +generateMainBlock pm genSeed = QC.unGen generator qcGen where qcGen = QC.mkQCGen genSeed generator = do prevHash <- arbitrary difficulty <- arbitrary - genMainBlock pm pc prevHash difficulty + genMainBlock pm prevHash difficulty diff --git a/block/test/Test/Pos/Block/Arbitrary/Message.hs b/block/test/Test/Pos/Block/Arbitrary/Message.hs index 95712a6b3de..d02754769b5 100644 --- a/block/test/Test/Pos/Block/Arbitrary/Message.hs +++ b/block/test/Test/Pos/Block/Arbitrary/Message.hs @@ -13,7 +13,7 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, import Pos.Arbitrary.Ssc () import qualified Pos.Block.Network.Types as T -import Pos.Core (HasGenesisHash, HasProtocolConstants) +import Pos.Core (HasGenesisHash) import Test.Pos.Block.Arbitrary () import Test.Pos.Core.Chrono () @@ -31,11 +31,11 @@ instance Arbitrary T.MsgGetBlocks where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary T.MsgHeaders where +instance Arbitrary T.MsgHeaders where arbitrary = genericArbitrary shrink = genericShrink -instance (HasProtocolConstants, HasGenesisHash) => Arbitrary T.MsgBlock where +instance HasGenesisHash => Arbitrary T.MsgBlock where arbitrary = genericArbitrary shrink = genericShrink @@ -51,9 +51,6 @@ instance Arbitrary T.MsgStreamUpdate where arbitrary = genericArbitrary shrink = genericShrink -instance ( HasProtocolConstants - , HasGenesisHash - ) => - Arbitrary T.MsgStreamBlock where +instance HasGenesisHash => Arbitrary T.MsgStreamBlock where arbitrary = genericArbitrary shrink = genericShrink diff --git a/client/cardano-sl-client.cabal b/client/cardano-sl-client.cabal index 767b7064264..bcbf3a0c540 100644 --- a/client/cardano-sl-client.cabal +++ b/client/cardano-sl-client.cabal @@ -104,6 +104,7 @@ test-suite cardano-client-test , cardano-sl , cardano-sl-client , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto , cardano-sl-crypto-test , cardano-sl-db diff --git a/client/src/Pos/Client/Txp/Addresses.hs b/client/src/Pos/Client/Txp/Addresses.hs index 1e876737538..d3cf004a325 100644 --- a/client/src/Pos/Client/Txp/Addresses.hs +++ b/client/src/Pos/Client/Txp/Addresses.hs @@ -6,7 +6,7 @@ module Pos.Client.Txp.Addresses import Universum -import Pos.Core (Address) +import Pos.Core (Address, SlotCount) -- | A class which have the method to generate a new address class Monad m => MonadAddresses m where @@ -14,9 +14,9 @@ class Monad m => MonadAddresses m where -- | Generate new address using given 'AddrData' (e.g. password + -- account id). - getNewAddress :: AddrData m -> m Address + getNewAddress :: SlotCount -> AddrData m -> m Address -- | Generate a “fake” change address. Its size must be greater -- than or equal to the maximal possible size of address generated -- by 'getNewAddress'. - getFakeChangeAddress :: m Address + getFakeChangeAddress :: SlotCount -> m Address diff --git a/client/src/Pos/Client/Txp/History.hs b/client/src/Pos/Client/Txp/History.hs index 8ce1bdf5a3d..7d957292587 100644 --- a/client/src/Pos/Client/Txp/History.hs +++ b/client/src/Pos/Client/Txp/History.hs @@ -39,7 +39,7 @@ import Serokell.Util.Text (listJson) import System.Wlog (WithLogger) import Pos.Core (Address, ChainDifficulty, GenesisHash (..), - HasConfiguration, Timestamp (..), difficultyL, epochSlots, + HasConfiguration, SlotCount, Timestamp (..), difficultyL, genesisHash, headerHash) import Pos.Core.Block (Block, MainBlock, mainBlockSlot, mainBlockTxPayload) @@ -169,17 +169,17 @@ genesisUtxoLookup = utxoToLookup . unGenesisUtxo $ genesisUtxo ---------------------------------------------------------------------------- -- | A class which have methods to get transaction history -class (Monad m, HasConfiguration) => MonadTxHistory m where +class Monad m => MonadTxHistory m where getBlockHistory - :: ProtocolMagic -> [Address] -> m (Map TxId TxHistoryEntry) + :: ProtocolMagic -> SlotCount -> [Address] -> m (Map TxId TxHistoryEntry) getLocalHistory :: [Address] -> m (Map TxId TxHistoryEntry) - saveTx :: ProtocolMagic -> (TxId, TxAux) -> m () + saveTx :: ProtocolMagic -> SlotCount -> (TxId, TxAux) -> m () default getBlockHistory :: (MonadTrans t, MonadTxHistory m', t m' ~ m) - => ProtocolMagic -> [Address] -> m (Map TxId TxHistoryEntry) - getBlockHistory pm = lift . getBlockHistory pm + => ProtocolMagic -> SlotCount -> [Address] -> m (Map TxId TxHistoryEntry) + getBlockHistory pm epochSlots = lift . getBlockHistory pm epochSlots default getLocalHistory :: (MonadTrans t, MonadTxHistory m', t m' ~ m) @@ -189,9 +189,10 @@ class (Monad m, HasConfiguration) => MonadTxHistory m where default saveTx :: (MonadTrans t, MonadTxHistory m', t m' ~ m) => ProtocolMagic + -> SlotCount -> (TxId, TxAux) -> m () - saveTx pm = lift . saveTx pm + saveTx pm epochSlots = lift . saveTx pm epochSlots instance {-# OVERLAPPABLE #-} (MonadTxHistory m, MonadTrans t, Monad (t m)) => @@ -217,9 +218,10 @@ getBlockHistoryDefault :: forall ctx m . (HasConfiguration, TxHistoryEnv ctx m) => ProtocolMagic + -> SlotCount -> [Address] -> m (Map TxId TxHistoryEntry) -getBlockHistoryDefault pm addrs = do +getBlockHistoryDefault pm epochSlots addrs = do let bot = headerHash (genesisBlock0 pm (GenesisHash genesisHash) (genesisLeaders epochSlots)) sd <- GS.getSlottingData systemStart <- getSystemStartM @@ -267,9 +269,10 @@ instance Exception SaveTxException where \case SaveTxToilFailure x -> toString (pretty x) -saveTxDefault :: TxHistoryEnv ctx m => ProtocolMagic -> (TxId, TxAux) -> m () -saveTxDefault pm txw = do - res <- txpProcessTx pm txw +saveTxDefault + :: TxHistoryEnv ctx m => ProtocolMagic -> SlotCount -> (TxId, TxAux) -> m () +saveTxDefault pm epochSlots txw = do + res <- txpProcessTx pm epochSlots txw eitherToThrow (first SaveTxToilFailure res) txHistoryListToMap :: [TxHistoryEntry] -> Map TxId TxHistoryEntry diff --git a/client/src/Pos/Client/Txp/Network.hs b/client/src/Pos/Client/Txp/Network.hs index 4836f791af5..10f1445b4ac 100644 --- a/client/src/Pos/Client/Txp/Network.hs +++ b/client/src/Pos/Client/Txp/Network.hs @@ -25,7 +25,7 @@ import Pos.Client.Txp.Util (InputSelectionPolicy, createMTx, createRedemptionTx) import Pos.Communication.Message () import Pos.Communication.Types (InvOrDataTK) -import Pos.Core (Address, Coin, makeRedeemAddress, mkCoin, +import Pos.Core (Address, Coin, SlotCount, makeRedeemAddress, mkCoin, unsafeAddCoin) import Pos.Core.Txp (TxAux (..), TxId, TxOut (..), TxOutAux (..), txaF) @@ -52,6 +52,7 @@ type TxMode m prepareMTx :: TxMode m => ProtocolMagic + -> SlotCount -> (Address -> Maybe SafeSigner) -> PendingAddresses -> InputSelectionPolicy @@ -59,9 +60,18 @@ prepareMTx -> NonEmpty TxOutAux -> AddrData m -> m (TxAux, NonEmpty TxOut) -prepareMTx pm hdwSigners pendingAddrs inputSelectionPolicy addrs outputs addrData = do - utxo <- getOwnUtxos (toList addrs) - eitherToThrow =<< createMTx pm pendingAddrs inputSelectionPolicy utxo hdwSigners outputs addrData +prepareMTx pm epochSlots hdwSigners pendingAddrs inputSelectionPolicy addrs outputs addrData + = do + utxo <- getOwnUtxos (toList addrs) + eitherToThrow + =<< createMTx pm + epochSlots + pendingAddrs + inputSelectionPolicy + utxo + hdwSigners + outputs + addrData -- | Construct redemption Tx using redemption secret key and a output address prepareRedemptionTx diff --git a/client/src/Pos/Client/Txp/Util.hs b/client/src/Pos/Client/Txp/Util.hs index ab5f97d3148..350ece3d47e 100644 --- a/client/src/Pos/Client/Txp/Util.hs +++ b/client/src/Pos/Client/Txp/Util.hs @@ -62,11 +62,11 @@ import Serokell.Util (listJson) import Pos.Binary (biSize) import Pos.Client.Txp.Addresses (MonadAddresses (..)) -import Pos.Core (Address, Coin, StakeholderId, TxFeePolicy (..), - TxSizeLinear (..), bvdTxFeePolicy, calculateTxSizeLinear, - coinToInteger, integerToCoin, isRedeemAddress, mkCoin, - sumCoins, txSizeLinearMinValue, unsafeIntegerToCoin, - unsafeSubCoin) +import Pos.Core (Address, Coin, SlotCount, StakeholderId, + TxFeePolicy (..), TxSizeLinear (..), bvdTxFeePolicy, + calculateTxSizeLinear, coinToInteger, integerToCoin, + isRedeemAddress, mkCoin, sumCoins, txSizeLinearMinValue, + unsafeIntegerToCoin, unsafeSubCoin) import Pos.Core.Configuration (HasConfiguration) import Pos.Crypto (ProtocolMagic, RedeemSecretKey, SafeSigner, SignTag (SignRedeemTx, SignTx), deterministicKeyGen, @@ -498,32 +498,35 @@ prepareTxRaw pendingTx utxo outputs fee = do -- Returns set of tx outputs including change output (if it's necessary) mkOutputsWithRem :: TxCreateMode m - => AddrData m + => SlotCount + -> AddrData m -> TxRaw -> TxCreator m TxOutputs -mkOutputsWithRem addrData TxRaw {..} +mkOutputsWithRem epochSlots addrData TxRaw {..} | trRemainingMoney == mkCoin 0 = pure trOutputs | otherwise = do - changeAddr <- lift . lift $ getNewAddress addrData + changeAddr <- lift . lift $ getNewAddress epochSlots addrData let txOut = TxOut changeAddr trRemainingMoney pure $ TxOutAux txOut :| toList trOutputs prepareInpsOuts :: TxCreateMode m => ProtocolMagic + -> SlotCount -> PendingAddresses -> Utxo -> TxOutputs -> AddrData m -> TxCreator m (TxOwnedInputs TxOut, TxOutputs) -prepareInpsOuts pm pendingTx utxo outputs addrData = do - txRaw@TxRaw {..} <- prepareTxWithFee pm pendingTx utxo outputs - outputsWithRem <- mkOutputsWithRem addrData txRaw +prepareInpsOuts pm epochSlots pendingTx utxo outputs addrData = do + txRaw@TxRaw {..} <- prepareTxWithFee pm epochSlots pendingTx utxo outputs + outputsWithRem <- mkOutputsWithRem epochSlots addrData txRaw pure (trInputs, outputsWithRem) createGenericTx :: TxCreateMode m => ProtocolMagic + -> SlotCount -> PendingAddresses -> (TxOwnedInputs TxOut -> TxOutputs -> Either TxError TxAux) -> InputSelectionPolicy @@ -531,15 +534,21 @@ createGenericTx -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createGenericTx pm pendingTx creator inputSelectionPolicy utxo outputs addrData = - runTxCreator inputSelectionPolicy $ do - (inps, outs) <- prepareInpsOuts pm pendingTx utxo outputs addrData +createGenericTx pm epochSlots pendingTx creator inputSelectionPolicy utxo outputs addrData + = runTxCreator inputSelectionPolicy $ do + (inps, outs) <- prepareInpsOuts pm + epochSlots + pendingTx + utxo + outputs + addrData txAux <- either throwError return $ creator inps outs pure (txAux, map fst inps) createGenericTxSingle :: TxCreateMode m => ProtocolMagic + -> SlotCount -> PendingAddresses -> (TxInputs -> TxOutputs -> Either TxError TxAux) -> InputSelectionPolicy @@ -547,13 +556,15 @@ createGenericTxSingle -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createGenericTxSingle pm pendingTx creator = createGenericTx pm pendingTx (creator . map snd) +createGenericTxSingle pm epochSlots pendingTx creator = + createGenericTx pm epochSlots pendingTx (creator . map snd) -- | Make a multi-transaction using given secret key and info for outputs. -- Currently used for HD wallets only, thus `HDAddressPayload` is required createMTx :: TxCreateMode m => ProtocolMagic + -> SlotCount -> PendingAddresses -> InputSelectionPolicy -> Utxo @@ -561,46 +572,64 @@ createMTx -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createMTx pm pendingTx groupInputs utxo hdwSigners outputs addrData = - createGenericTx pm pendingTx (makeMPubKeyTxAddrs pm getSigner) - groupInputs utxo outputs addrData +createMTx pm epochSlots pendingTx groupInputs utxo hdwSigners outputs addrData + = createGenericTx pm + epochSlots + pendingTx + (makeMPubKeyTxAddrs pm getSigner) + groupInputs + utxo + outputs + addrData where - getSigner address = - note (SafeSignerNotFound address) $ - hdwSigners address + getSigner address = note (SafeSignerNotFound address) $ hdwSigners address -- | Make a multi-transaction using given secret key and info for -- outputs. createTx :: TxCreateMode m => ProtocolMagic + -> SlotCount -> PendingAddresses -> Utxo -> SafeSigner -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createTx pm pendingTx utxo ss outputs addrData = - createGenericTxSingle pm pendingTx (\i o -> Right $ makePubKeyTx pm ss i o) - OptimizeForHighThroughput utxo outputs addrData +createTx pm epochSlots pendingTx utxo ss outputs addrData = + createGenericTxSingle pm + epochSlots + pendingTx + (\i o -> Right $ makePubKeyTx pm ss i o) + OptimizeForHighThroughput + utxo + outputs + addrData -- | Make a transaction, using M-of-N script as a source createMOfNTx :: TxCreateMode m => ProtocolMagic + -> SlotCount -> PendingAddresses -> Utxo -> [(StakeholderId, Maybe SafeSigner)] -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createMOfNTx pm pendingTx utxo keys outputs addrData = - createGenericTxSingle pm pendingTx (\i o -> Right $ makeMOfNTx pm validator sks i o) - OptimizeForSecurity utxo outputs addrData +createMOfNTx pm epochSlots pendingTx utxo keys outputs addrData = + createGenericTxSingle pm + epochSlots + pendingTx + (\i o -> Right $ makeMOfNTx pm validator sks i o) + OptimizeForSecurity + utxo + outputs + addrData where - ids = map fst keys - sks = map snd keys - m = length $ filter isJust sks + ids = map fst keys + sks = map snd keys + m = length $ filter isJust sks validator = multisigValidator pm m ids -- | Make a transaction for retrieving money from redemption address @@ -639,24 +668,26 @@ withLinearFeePolicy action = view tcdFeePolicy >>= \case prepareTxWithFee :: MonadAddresses m => ProtocolMagic + -> SlotCount -> PendingAddresses -> Utxo -> TxOutputs -> TxCreator m TxRaw -prepareTxWithFee pm pendingTx utxo outputs = withLinearFeePolicy $ \linearPolicy -> - stabilizeTxFee pm pendingTx linearPolicy utxo outputs +prepareTxWithFee pm epochSlots pendingTx utxo outputs = withLinearFeePolicy $ \linearPolicy -> + stabilizeTxFee pm epochSlots pendingTx linearPolicy utxo outputs -- | Compute, how much fees we should pay to send money to given -- outputs computeTxFee :: MonadAddresses m => ProtocolMagic + -> SlotCount -> PendingAddresses -> Utxo -> TxOutputs -> TxCreator m TxFee -computeTxFee pm pendingTx utxo outputs = do - TxRaw {..} <- prepareTxWithFee pm pendingTx utxo outputs +computeTxFee pm epochSlots pendingTx utxo outputs = do + TxRaw {..} <- prepareTxWithFee pm epochSlots pendingTx utxo outputs let outAmount = sumTxOutCoins trOutputs inAmount = sumCoins $ map (txOutValue . fst) trInputs remaining = coinToInteger trRemainingMoney @@ -710,12 +741,13 @@ stabilizeTxFee :: forall m . MonadAddresses m => ProtocolMagic + -> SlotCount -> PendingAddresses -> TxSizeLinear -> Utxo -> TxOutputs -> TxCreator m TxRaw -stabilizeTxFee pm pendingTx linearPolicy utxo outputs = do +stabilizeTxFee pm epochSlots pendingTx linearPolicy utxo outputs = do minFee <- fixedToFee (txSizeLinearMinValue linearPolicy) mtx <- stabilizeTxFeeDo (False, firstStageAttempts) minFee case mtx of @@ -731,7 +763,7 @@ stabilizeTxFee pm pendingTx linearPolicy utxo outputs = do stabilizeTxFeeDo (_, 0) _ = pure Nothing stabilizeTxFeeDo (isSecondStage, attempt) expectedFee = do txRaw <- prepareTxRaw pendingTx utxo outputs expectedFee - fakeChangeAddr <- lift . lift $ getFakeChangeAddress + fakeChangeAddr <- lift . lift $ getFakeChangeAddress epochSlots txMinFee <- txToLinearFee linearPolicy $ createFakeTxFromRawTx pm fakeChangeAddr txRaw diff --git a/client/test/Test/Pos/Client/Txp/Mode.hs b/client/test/Test/Pos/Client/Txp/Mode.hs index 533a4ab389a..cf41f6ad761 100644 --- a/client/test/Test/Pos/Client/Txp/Mode.hs +++ b/client/test/Test/Pos/Client/Txp/Mode.hs @@ -55,8 +55,8 @@ instance MonadGState TxpTestMode where instance MonadAddresses TxpTestMode where type AddrData TxpTestMode = () - getNewAddress _ = pure fakeAddressForMonadAddresses - getFakeChangeAddress = pure fakeAddressForMonadAddresses + getNewAddress _ _ = pure fakeAddressForMonadAddresses + getFakeChangeAddress _ = pure fakeAddressForMonadAddresses fakeAddressForMonadAddresses :: Address fakeAddressForMonadAddresses = address @@ -83,8 +83,8 @@ type TxpTestProperty = PropertyM TxpTestMode -- type families cannot be OVERLAPPABLE. instance MonadAddresses TxpTestProperty where type AddrData TxpTestProperty = AddrData TxpTestMode - getNewAddress = lift . getNewAddress - getFakeChangeAddress = lift getFakeChangeAddress + getNewAddress epochSlots = lift . getNewAddress epochSlots + getFakeChangeAddress = lift . getFakeChangeAddress instance (HasTxpConfigurations, Testable a) => Testable (TxpTestProperty a) where property = monadic (ioProperty . flip runReaderT genesisBlockVersionData) diff --git a/client/test/Test/Pos/Client/Txp/UtilSpec.hs b/client/test/Test/Pos/Client/Txp/UtilSpec.hs index 70583779674..49fbce77735 100644 --- a/client/test/Test/Pos/Client/Txp/UtilSpec.hs +++ b/client/test/Test/Pos/Client/Txp/UtilSpec.hs @@ -39,6 +39,7 @@ import Pos.Util.Util (leftToPanic) import Test.Pos.Client.Txp.Mode (HasTxpConfigurations, TxpTestMode, TxpTestProperty, withBVData) import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Core.Dummy (dummyEpochSlots) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Arbitrary (nonrepeating) import Test.Pos.Util.QuickCheck.Property (stopProperty) @@ -48,7 +49,7 @@ import Test.Pos.Util.QuickCheck.Property (stopProperty) ---------------------------------------------------------------------------- spec :: Spec -spec = withDefConfigurations $ \_ _ -> +spec = withDefConfigurations $ \_ -> describe "Client.Txp.Util" $ do describe "createMTx" $ createMTxSpec @@ -115,9 +116,15 @@ testCreateMTx :: HasTxpConfigurations => CreateMTxParams -> TxpTestProperty (Either TxError (TxAux, NonEmpty TxOut)) -testCreateMTx CreateMTxParams{..} = lift $ - createMTx dummyProtocolMagic mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) - cmpOutputs cmpAddrData +testCreateMTx CreateMTxParams {..} = lift $ createMTx + dummyProtocolMagic + dummyEpochSlots + mempty + cmpInputSelectionPolicy + cmpUtxo + (getSignerFromList cmpSigners) + cmpOutputs + cmpAddrData createMTxWorksWhenWeAreRichSpec :: HasTxpConfigurations @@ -221,25 +228,31 @@ redemptionSpec = do pure CreateRedemptionTxParams {..} txWithRedeemOutputFailsSpec - :: HasTxpConfigurations - => InputSelectionPolicy - -> TxpTestProperty () + :: HasTxpConfigurations => InputSelectionPolicy -> TxpTestProperty () txWithRedeemOutputFailsSpec inputSelectionPolicy = do forAllM genParams $ \(CreateMTxParams {..}) -> do - txOrError <- - createMTx dummyProtocolMagic mempty cmpInputSelectionPolicy cmpUtxo - (getSignerFromList cmpSigners) - cmpOutputs cmpAddrData + txOrError <- createMTx dummyProtocolMagic + dummyEpochSlots + mempty + cmpInputSelectionPolicy + cmpUtxo + (getSignerFromList cmpSigners) + cmpOutputs + cmpAddrData case txOrError of - Left (OutputIsRedeem _) -> return () - Left err -> stopProperty $ pretty err - Right _ -> stopProperty $ - sformat ("Transaction to a redeem address was created") + Left (OutputIsRedeem _) -> return () + Left err -> stopProperty $ pretty err + Right _ -> stopProperty + $ sformat ("Transaction to a redeem address was created") where genParams = do txOutAuxOutput <- generateRedeemTxOutAux 1 <$> arbitrary - params <- makeManyAddressesToManyParams inputSelectionPolicy 1 1000000 1 1 - pure params{ cmpOutputs = one txOutAuxOutput } + params <- makeManyAddressesToManyParams inputSelectionPolicy + 1 + 1000000 + 1 + 1 + pure params { cmpOutputs = one txOutAuxOutput } feeForManyAddressesSpec :: HasTxpConfigurations diff --git a/core/cardano-sl-core.cabal b/core/cardano-sl-core.cabal index 56f0d445d3b..4314ba19ada 100644 --- a/core/cardano-sl-core.cabal +++ b/core/cardano-sl-core.cabal @@ -95,7 +95,6 @@ library Pos.Core.Configuration.GeneratedSecrets Pos.Core.Configuration.GenesisData Pos.Core.Configuration.GenesisHash - Pos.Core.Configuration.Protocol -- Context Pos.Core.Context.PrimaryKey @@ -265,6 +264,7 @@ test-suite test Test.Pos.Core.Arbitrary Test.Pos.Core.Arbitrary.Unsafe + Test.Pos.Core.Dummy build-depends: base , base16-bytestring diff --git a/core/src/Pos/Core/Configuration.hs b/core/src/Pos/Core/Configuration.hs index 69b57313c09..e5d8dec0c0d 100644 --- a/core/src/Pos/Core/Configuration.hs +++ b/core/src/Pos/Core/Configuration.hs @@ -25,7 +25,6 @@ import Pos.Core.Configuration.Core as E import Pos.Core.Configuration.GeneratedSecrets as E import Pos.Core.Configuration.GenesisData as E import Pos.Core.Configuration.GenesisHash as E -import Pos.Core.Configuration.Protocol as E import Pos.Core.Genesis (GenesisData (..), GenesisDelegation, GenesisInitializer (..), GenesisProtocolConstants (..), GenesisSpec (..), @@ -34,6 +33,7 @@ import Pos.Core.Genesis (GenesisData (..), GenesisDelegation, import Pos.Core.Genesis.Canonical (SchemaError) import Pos.Core.Genesis.Generate (GeneratedGenesisData (..), generateGenesisData) +import Pos.Core.ProtocolConstants (ProtocolConstants) import Pos.Core.Slotting (Timestamp) import Pos.Crypto.Configuration as E import Pos.Crypto.Hashing (Hash, hashRaw, unsafeHash) @@ -46,7 +46,6 @@ type HasConfiguration = , HasGenesisHash , HasGeneratedSecrets , HasGenesisBlockVersionData - , HasProtocolConstants ) canonicalGenesisJson :: GenesisData -> (BSL.ByteString, Hash Raw) @@ -87,7 +86,7 @@ withCoreConfigurations -> Maybe Integer -- ^ Optional seed which overrides one from testnet initializer if -- provided. - -> (HasConfiguration => ProtocolMagic -> m r) + -> (HasConfiguration => ProtocolMagic -> ProtocolConstants -> m r) -> m r withCoreConfigurations conf@CoreConfiguration{..} confDir mSystemStart mSeed act = case ccGenesis of -- If a 'GenesisData' source file is given, we check its hash against the @@ -116,12 +115,11 @@ withCoreConfigurations conf@CoreConfiguration{..} confDir mSystemStart mSeed act (show theGenesisHash) (show expectedHash) withCoreConfiguration conf $ - withProtocolConstants pc $ withGenesisBlockVersionData (gdBlockVersionData theGenesisData) $ withGenesisData theGenesisData $ withGenesisHash theGenesisHash $ withGeneratedSecrets Nothing $ - act pm + act pm pc -- If a 'GenesisSpec' is given, we ensure we have a start time (needed if -- it's a testnet initializer) and then make a 'GenesisData' from it. @@ -149,17 +147,16 @@ withCoreConfigurations conf@CoreConfiguration{..} confDir mSystemStart mSeed act withGenesisSpec :: Timestamp -> CoreConfiguration - -> (HasConfiguration => ProtocolMagic -> r) + -> (HasConfiguration => ProtocolMagic -> ProtocolConstants -> r) -> r withGenesisSpec theSystemStart conf@CoreConfiguration{..} val = case ccGenesis of GCSrc {} -> error "withGenesisSpec called with GCSrc" GCSpec spec -> - withProtocolConstants pc $ withGenesisBlockVersionData (gsBlockVersionData spec) $ let -- Generate GeneratedGenesisData {..} = - generateGenesisData pm (gsInitializer spec) (gsAvvmDistr spec) + generateGenesisData pm pc (gsInitializer spec) (gsAvvmDistr spec) -- Unite with generated finalHeavyDelegation :: GenesisDelegation @@ -186,7 +183,7 @@ withGenesisSpec theSystemStart conf@CoreConfiguration{..} val = case ccGenesis o in withCoreConfiguration conf $ withGenesisHash theGenesisHash $ withGeneratedSecrets (Just ggdSecrets) $ - withGenesisData theGenesisData $ val pm + withGenesisData theGenesisData $ val pm pc where pm = gpcProtocolMagic (gsProtocolConstants spec) pc = genesisProtocolConstantsToProtocolConstants (gsProtocolConstants spec) diff --git a/core/src/Pos/Core/Configuration/Protocol.hs b/core/src/Pos/Core/Configuration/Protocol.hs deleted file mode 100644 index 775b8f4caac..00000000000 --- a/core/src/Pos/Core/Configuration/Protocol.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE Rank2Types #-} - -module Pos.Core.Configuration.Protocol - ( - HasProtocolConstants - , withProtocolConstants - , protocolConstants - , vssMaxTTL - , vssMinTTL - , blkSecurityParam - , slotSecurityParam - , epochSlots - , chainQualityThreshold - - ) where - -import Universum - -import Data.Reflection (Given (..), give) - -import Pos.Core.Common (BlockCount (..)) -import Pos.Core.ProtocolConstants (ProtocolConstants (..), - VssMaxTTL (..), VssMinTTL (..)) -import Pos.Core.Slotting.SlotCount (SlotCount) - -type HasProtocolConstants = Given ProtocolConstants - -withProtocolConstants :: - ProtocolConstants - -> (HasProtocolConstants => r) - -> r -withProtocolConstants = give - -protocolConstants :: HasProtocolConstants => ProtocolConstants -protocolConstants = given - --- | VSS certificates max timeout to live (number of epochs) -vssMaxTTL :: (HasProtocolConstants, Integral i) => i -vssMaxTTL = fromIntegral . getVssMaxTTL . pcVssMaxTTL $ protocolConstants - --- | VSS certificates min timeout to live (number of epochs) -vssMinTTL :: (HasProtocolConstants, Integral i) => i -vssMinTTL = fromIntegral . getVssMinTTL . pcVssMinTTL $ protocolConstants - --- | Security parameter which is maximum number of blocks which can be --- rolled back. -blkSecurityParam :: HasProtocolConstants => BlockCount -blkSecurityParam = fromIntegral . pcK $ protocolConstants - --- | Security parameter expressed in number of slots. It uses chain --- quality property. It's basically @blkSecurityParam / chainQualityThreshold@. -slotSecurityParam :: HasProtocolConstants => SlotCount -slotSecurityParam = fromIntegral $ 2 * getBlockCount blkSecurityParam - --- We don't have a special newtype for it, so it can be any --- 'Fractional'. I think adding newtype here would be overkill --- (@gromak). Also this value is not actually part of the protocol, --- but rather implementation detail, so we don't need to ensure --- conrete precision. Apart from that, in reality we know that it's --- 0.5, so any fractional type should be fine ☺ --- --- | Minimal chain quality (number of blocks divided by number of --- slots) necessary for security of the system. -chainQualityThreshold :: (HasProtocolConstants, Fractional fractional) => fractional -chainQualityThreshold = - realToFrac blkSecurityParam / realToFrac slotSecurityParam - --- | Number of slots inside one epoch. -epochSlots :: (HasProtocolConstants) => SlotCount -epochSlots = fromIntegral $ 10 * getBlockCount blkSecurityParam diff --git a/core/src/Pos/Core/Genesis/Generate.hs b/core/src/Pos/Core/Genesis/Generate.hs index 03bf42f1f6a..4dcded551c4 100644 --- a/core/src/Pos/Core/Genesis/Generate.hs +++ b/core/src/Pos/Core/Genesis/Generate.hs @@ -30,9 +30,9 @@ import Pos.Core.Common (Address, Coin, IsBootstrapEraAddr (..), coinToInteger, deriveFirstHDAddress, makePubKeyAddressBoot, mkCoin, sumCoins, unsafeIntegerToCoin) -import Pos.Core.Configuration.Protocol (HasProtocolConstants, - vssMaxTTL, vssMinTTL) import Pos.Core.Delegation (HeavyDlgIndex (..), ProxySKHeavy) +import Pos.Core.ProtocolConstants (ProtocolConstants, vssMaxTTL, + vssMinTTL) import Pos.Core.Ssc (VssCertificate, mkVssCertificate, mkVssCertificatesMap) import Pos.Crypto (EncryptedSecretKey, ProtocolMagic, RedeemPublicKey, @@ -97,12 +97,12 @@ data GeneratedSecrets = GeneratedSecrets } generateGenesisData - :: HasProtocolConstants - => ProtocolMagic + :: ProtocolMagic + -> ProtocolConstants -> GenesisInitializer -> GenesisAvvmBalances -> GeneratedGenesisData -generateGenesisData pm (GenesisInitializer{..}) realAvvmBalances = deterministic (serialize' giSeed) $ do +generateGenesisData pm pc (GenesisInitializer{..}) realAvvmBalances = deterministic (serialize' giSeed) $ do let TestnetBalanceOptions{..} = giTestBalance -- apply ggdAvvmBalanceFactor @@ -158,7 +158,7 @@ generateGenesisData pm (GenesisInitializer{..}) realAvvmBalances = deterministic map ((,1) . addressHash . toPublic) bootSecrets -- VSS certificates - vssCertsList <- mapM (generateVssCert pm) richmenSecrets + vssCertsList <- mapM (generateVssCert pm pc) richmenSecrets let toVss = mkVssCertificatesMap vssCerts = GenesisVssCertificatesMap $ toVss vssCertsList @@ -247,14 +247,15 @@ generateFakeAvvmGenesis FakeAvvmOptions{..} = do , map snd fakeAvvmPubkeysAndSeeds , faoOneBalance * fromIntegral faoCount) -generateVssCert :: - (HasProtocolConstants, MonadRandom m) +generateVssCert + :: MonadRandom m => ProtocolMagic + -> ProtocolConstants -> RichSecrets -> m VssCertificate -generateVssCert pm RichSecrets {..} = do +generateVssCert pm pc RichSecrets {..} = do expiry <- fromInteger <$> - randomNumberInRange (vssMinTTL - 1) (vssMaxTTL - 1) + randomNumberInRange (vssMinTTL pc - 1) (vssMaxTTL pc - 1) let vssPk = asBinary $ toVssPublicKey rsVssKeyPair vssCert = mkVssCertificate pm rsPrimaryKey vssPk expiry return vssCert diff --git a/core/src/Pos/Core/ProtocolConstants.hs b/core/src/Pos/Core/ProtocolConstants.hs index 26890c5fea1..b1de44f3d2d 100644 --- a/core/src/Pos/Core/ProtocolConstants.hs +++ b/core/src/Pos/Core/ProtocolConstants.hs @@ -1,15 +1,24 @@ -- | Protocol constants and some derived terms. module Pos.Core.ProtocolConstants - ( ProtocolConstants (..) - , VssMinTTL (..) - , VssMaxTTL (..) + ( ProtocolConstants (..) + , VssMinTTL (..) + , VssMaxTTL (..) - , pcBlkSecurityParam - , pcSlotSecurityParam - , pcChainQualityThreshold - , pcEpochSlots - ) where + , vssMaxTTL + , vssMinTTL + + , pcBlkSecurityParam + + , pcSlotSecurityParam + , kSlotSecurityParam + + , pcChainQualityThreshold + , kChainQualityThreshold + + , pcEpochSlots + , kEpochSlots + ) where import Universum @@ -36,6 +45,14 @@ newtype VssMaxTTL = VssMaxTTL { getVssMaxTTL :: Word32 } deriving (Eq, Show, Bounded, Enum, Generic) +-- | VSS certificates max timeout to live (number of epochs) +vssMaxTTL :: Integral i => ProtocolConstants -> i +vssMaxTTL = fromIntegral . getVssMaxTTL . pcVssMaxTTL + +-- | VSS certificates min timeout to live (number of epochs) +vssMinTTL :: Integral i => ProtocolConstants -> i +vssMinTTL = fromIntegral . getVssMinTTL . pcVssMinTTL + -- | Security parameter which is maximum number of blocks which can be -- rolled back. pcBlkSecurityParam :: ProtocolConstants -> BlockCount @@ -44,7 +61,10 @@ pcBlkSecurityParam = fromIntegral . pcK -- | Security parameter expressed in number of slots. It uses chain -- quality property. It's basically @blkSecurityParam / chainQualityThreshold@. pcSlotSecurityParam :: ProtocolConstants -> SlotCount -pcSlotSecurityParam = fromIntegral . (*) 2 . getBlockCount . pcBlkSecurityParam +pcSlotSecurityParam = kSlotSecurityParam . pcBlkSecurityParam + +kSlotSecurityParam :: BlockCount -> SlotCount +kSlotSecurityParam = fromIntegral . (*) 2 . getBlockCount -- We don't have a special newtype for it, so it can be any -- 'Fractional'. I think adding newtype here would be overkill @@ -55,13 +75,18 @@ pcSlotSecurityParam = fromIntegral . (*) 2 . getBlockCount . pcBlkSecurityParam -- -- | Minimal chain quality (number of blocks divided by number of -- slots) necessary for security of the system. -pcChainQualityThreshold :: (Fractional fractional) => ProtocolConstants -> fractional -pcChainQualityThreshold pc = - realToFrac (pcBlkSecurityParam pc) / realToFrac (pcSlotSecurityParam pc) +pcChainQualityThreshold :: Fractional f => ProtocolConstants -> f +pcChainQualityThreshold = kChainQualityThreshold . pcBlkSecurityParam + +kChainQualityThreshold :: Fractional f => BlockCount -> f +kChainQualityThreshold k = realToFrac k / realToFrac (kSlotSecurityParam k) -- | Number of slots inside one epoch. -- -- FIXME strange that it's defined in terms of block security param. -- Shouldn't it be the other way around? pcEpochSlots :: ProtocolConstants -> SlotCount -pcEpochSlots = fromIntegral . (*) 10 . getBlockCount . pcBlkSecurityParam +pcEpochSlots = kEpochSlots . pcBlkSecurityParam + +kEpochSlots :: BlockCount -> SlotCount +kEpochSlots = fromIntegral . (*) 10 . getBlockCount diff --git a/core/src/Pos/Core/Slotting/EpochOrSlot.hs b/core/src/Pos/Core/Slotting/EpochOrSlot.hs index bdd01763b2b..115318a2a46 100644 --- a/core/src/Pos/Core/Slotting/EpochOrSlot.hs +++ b/core/src/Pos/Core/Slotting/EpochOrSlot.hs @@ -1,9 +1,18 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Pos.Core.Slotting.EpochOrSlot ( EpochOrSlot (..) , HasEpochOrSlot (..) + , epochOrSlotToEnum + , epochOrSlotFromEnum + , epochOrSlotSucc + , epochOrSlotPred + , epochOrSlotEnumFromTo + + , epochOrSlotMinBound + , epochOrSlotMaxBound + , flattenEpochOrSlot , diffEpochOrSlot @@ -20,8 +29,6 @@ import qualified Data.Text.Buildable as Buildable import Pos.Util.Some (Some, applySome) import Pos.Binary.Class (Bi (..)) -import Pos.Core.Configuration.Protocol (HasProtocolConstants, - epochSlots) import Pos.Util.Util (leftToPanic) import Pos.Core.Slotting.EpochIndex @@ -62,47 +69,75 @@ instance HasEpochIndex EpochOrSlot where setter (EpochOrSlot (Right slot)) epoch = EpochOrSlot (Right $ set epochIndexL epoch slot) -instance HasProtocolConstants => Enum EpochOrSlot where - succ (EpochOrSlot (Left e)) = - EpochOrSlot (Right SlotId {siEpoch = e, siSlot = minBound}) - succ e@(EpochOrSlot (Right si@SlotId {..})) - | e == maxBound = error "succ@EpochOrSlot: maxBound" - | siSlot == maxBound = EpochOrSlot (Left (siEpoch + 1)) - | otherwise = EpochOrSlot $ Right si {siSlot = succ siSlot} - pred eos@(EpochOrSlot (Left e)) - | eos == minBound = error "pred@EpochOrSlot: minBound" - | otherwise = - EpochOrSlot (Right SlotId {siEpoch = e - 1, siSlot = maxBound}) - pred (EpochOrSlot (Right si@SlotId {..})) - | siSlot == minBound = EpochOrSlot (Left siEpoch) - | otherwise = EpochOrSlot $ Right si {siSlot = pred siSlot} - fromEnum (EpochOrSlot (Left e)) = +epochOrSlotToEnum :: SlotCount -> Int -> EpochOrSlot +epochOrSlotToEnum epochSlots x = + let + (fromIntegral -> epoch, fromIntegral -> slot) = + x `divMod` (fromIntegral epochSlots + 1) + slotIdx = + leftToPanic "toEnum @EpochOrSlot" $ mkLocalSlotIndex epochSlots (slot - 1) + in + if | x < 0 -> error "toEnum @EpochOrSlot: Negative argument" + | slot == 0 -> EpochOrSlot (Left epoch) + | otherwise -> + EpochOrSlot (Right SlotId {siSlot = slotIdx, siEpoch = epoch}) + +epochOrSlotFromEnum :: SlotCount -> EpochOrSlot -> Int +epochOrSlotFromEnum epochSlots = \case + (EpochOrSlot (Left e)) -> let res = toInteger e * toInteger (epochSlots + 1) maxIntAsInteger = toInteger (maxBound :: Int) in if | res > maxIntAsInteger -> error "fromEnum @EpochOrSlot: Argument larger than 'maxBound :: Int'" | otherwise -> fromIntegral res - fromEnum (EpochOrSlot (Right SlotId {..})) = - let res = toInteger (fromEnum (EpochOrSlot (Left siEpoch))) + + (EpochOrSlot (Right SlotId {..})) -> + let res = toInteger (epochOrSlotFromEnum epochSlots (EpochOrSlot (Left siEpoch))) + toInteger (getSlotIndex siSlot) + 1 maxIntAsInteger = toInteger (maxBound :: Int) in if | res > maxIntAsInteger -> error "fromEnum @EpochOrSlot: Argument larger than 'maxBound :: Int'" | otherwise -> fromIntegral res - toEnum x = - let (fromIntegral -> epoch, fromIntegral -> slot) = - x `divMod` (fromIntegral epochSlots + 1) - slotIdx = - leftToPanic "toEnum @EpochOrSlot" $ mkLocalSlotIndex (slot - 1) - in if | x < 0 -> error "toEnum @EpochOrSlot: Negative argument" - | slot == 0 -> EpochOrSlot (Left epoch) - | otherwise -> - EpochOrSlot (Right SlotId {siSlot = slotIdx, siEpoch = epoch}) - -instance HasProtocolConstants => Bounded EpochOrSlot where - maxBound = EpochOrSlot (Right SlotId {siSlot = maxBound, siEpoch = maxBound}) - minBound = EpochOrSlot (Left (EpochIndex 0)) + +epochOrSlotSucc :: SlotCount -> EpochOrSlot -> EpochOrSlot +epochOrSlotSucc epochSlots = \case + (EpochOrSlot (Left e)) -> EpochOrSlot + (Right SlotId {siEpoch = e, siSlot = localSlotIndexMinBound}) + e@(EpochOrSlot (Right si@SlotId {..})) + | e == epochOrSlotMaxBound epochSlots -> error + "succ@EpochOrSlot: maxBound" + | siSlot == localSlotIndexMaxBound epochSlots -> EpochOrSlot + (Left (siEpoch + 1)) + | otherwise -> EpochOrSlot + $ Right si { siSlot = localSlotIndexSucc epochSlots siSlot } + +epochOrSlotPred :: SlotCount -> EpochOrSlot -> EpochOrSlot +epochOrSlotPred epochSlots = \case + eos@(EpochOrSlot (Left e)) + | eos == epochOrSlotMinBound -> error "epochOrSlotPred: minBound" + | otherwise -> EpochOrSlot $ Right SlotId + { siEpoch = e - 1 + , siSlot = localSlotIndexMaxBound epochSlots + } + (EpochOrSlot (Right si@SlotId {..})) + | siSlot == localSlotIndexMinBound -> EpochOrSlot (Left siEpoch) + | otherwise -> EpochOrSlot + $ Right si { siSlot = localSlotIndexPred epochSlots siSlot } + +epochOrSlotEnumFromTo + :: SlotCount -> EpochOrSlot -> EpochOrSlot -> [EpochOrSlot] +epochOrSlotEnumFromTo epochSlots x y = fmap + (epochOrSlotToEnum epochSlots) + [epochOrSlotFromEnum epochSlots x .. epochOrSlotFromEnum epochSlots y] + +epochOrSlotMinBound :: EpochOrSlot +epochOrSlotMinBound = EpochOrSlot (Left (EpochIndex 0)) + +epochOrSlotMaxBound :: SlotCount -> EpochOrSlot +epochOrSlotMaxBound epochSlots = EpochOrSlot $ Right SlotId + { siSlot = localSlotIndexMaxBound epochSlots + , siEpoch = maxBound + } class HasEpochOrSlot a where getEpochOrSlot :: a -> EpochOrSlot @@ -127,22 +162,23 @@ instance (HasEpochOrSlot a, HasEpochOrSlot b) => getEpochOrSlot = either getEpochOrSlot getEpochOrSlot -- | Transforms some 'HasEpochOrSlot' to a single number. -flattenEpochOrSlot :: (HasProtocolConstants, HasEpochOrSlot a) => a -> FlatSlotId -flattenEpochOrSlot = - epochOrSlot flattenEpochIndex flattenSlotId . getEpochOrSlot +flattenEpochOrSlot :: HasEpochOrSlot a => SlotCount -> a -> FlatSlotId +flattenEpochOrSlot epochSlots = + epochOrSlot (flattenEpochIndex epochSlots) (flattenSlotId epochSlots) + . getEpochOrSlot -- | Distance (in slots) between two slots. The first slot is newer, the -- second slot is older. An epoch is considered the same as the 0th slot of -- that epoch. -- -- If the difference is negative, the result will be 'Nothing'. -diffEpochOrSlot :: HasProtocolConstants => EpochOrSlot -> EpochOrSlot -> Maybe SlotCount -diffEpochOrSlot a b +diffEpochOrSlot :: SlotCount -> EpochOrSlot -> EpochOrSlot -> Maybe SlotCount +diffEpochOrSlot epochSlots a b | a' < b' = Nothing | otherwise = Just (fromInteger (a' - b')) where - a' = toInteger (flattenEpochOrSlot a) - b' = toInteger (flattenEpochOrSlot b) + a' = toInteger (flattenEpochOrSlot epochSlots a) + b' = toInteger (flattenEpochOrSlot epochSlots b) -- | Apply one of the function depending on content of 'EpochOrSlot'. @@ -152,5 +188,5 @@ epochOrSlot f g = either f g . unEpochOrSlot -- | Convert 'EpochOrSlot' to the corresponding slot. If slot is -- stored, it's returned, otherwise 0-th slot from the stored epoch is -- returned. -epochOrSlotToSlot :: HasProtocolConstants => EpochOrSlot -> SlotId -epochOrSlotToSlot = epochOrSlot (flip SlotId minBound) identity +epochOrSlotToSlot :: EpochOrSlot -> SlotId +epochOrSlotToSlot = epochOrSlot (flip SlotId localSlotIndexMinBound) identity diff --git a/core/src/Pos/Core/Slotting/LocalSlotIndex.hs b/core/src/Pos/Core/Slotting/LocalSlotIndex.hs index 79973429eb6..5c33455aac0 100644 --- a/core/src/Pos/Core/Slotting/LocalSlotIndex.hs +++ b/core/src/Pos/Core/Slotting/LocalSlotIndex.hs @@ -2,16 +2,18 @@ module Pos.Core.Slotting.LocalSlotIndex ( LocalSlotIndex (..) , mkLocalSlotIndex - , mkLocalSlotIndexExplicit - , mkLocalSlotIndexThrow_ , addLocalSlotIndex + , localSlotIndexToEnum + , localSlotIndexFromEnum + , localSlotIndexSucc + , localSlotIndexPred + , localSlotIndexMinBound , localSlotIndexMaxBound , localSlotIndices , unsafeMkLocalSlotIndex - , unsafeMkLocalSlotIndexExplicit ) where import Universum @@ -21,9 +23,6 @@ import Data.Ix (Ix) import System.Random (Random (..)) import Pos.Binary.Class (Bi (..)) -import Pos.Core.Configuration.Protocol (HasProtocolConstants, - epochSlots, protocolConstants) -import Pos.Core.ProtocolConstants (ProtocolConstants, pcEpochSlots) import Pos.Util.Util (leftToPanic) import Pos.Core.Slotting.SlotCount (SlotCount) @@ -33,22 +32,30 @@ newtype LocalSlotIndex = UnsafeLocalSlotIndex { getSlotIndex :: Word16 } deriving (Show, Eq, Ord, Ix, Generic, Hashable, Buildable, Typeable, NFData) -instance HasProtocolConstants => Enum LocalSlotIndex where - toEnum i | i >= fromIntegral epochSlots = error "toEnum @LocalSlotIndex: greater than maxBound" - | i < 0 = error "toEnum @LocalSlotIndex: less than minBound" - | otherwise = UnsafeLocalSlotIndex (fromIntegral i) - fromEnum = fromIntegral . getSlotIndex +localSlotIndexToEnum :: SlotCount -> Int -> LocalSlotIndex +localSlotIndexToEnum epochSlots i + | i >= fromIntegral epochSlots = error + "toEnum @LocalSlotIndex: greater than maxBound" + | i < 0 = error "toEnum @LocalSlotIndex: less than minBound" + | otherwise = UnsafeLocalSlotIndex (fromIntegral i) + +localSlotIndexFromEnum :: LocalSlotIndex -> Int +localSlotIndexFromEnum = fromIntegral . getSlotIndex + +localSlotIndexSucc :: SlotCount -> LocalSlotIndex -> LocalSlotIndex +localSlotIndexSucc epochSlots = + localSlotIndexToEnum epochSlots . (+ 1) . localSlotIndexFromEnum -instance HasProtocolConstants => Random LocalSlotIndex where - random = randomR (minBound, maxBound) +localSlotIndexPred :: SlotCount -> LocalSlotIndex -> LocalSlotIndex +localSlotIndexPred epochSlots = + localSlotIndexToEnum epochSlots . subtract 1 . localSlotIndexFromEnum + +instance Random LocalSlotIndex where + random = error "random @LocalSlotIndex: undefined" randomR (UnsafeLocalSlotIndex lo, UnsafeLocalSlotIndex hi) g = let (r, g') = randomR (lo, hi) g in (UnsafeLocalSlotIndex r, g') -instance HasProtocolConstants => Bounded LocalSlotIndex where - minBound = UnsafeLocalSlotIndex 0 - maxBound = UnsafeLocalSlotIndex (fromIntegral epochSlots - 1) - instance Bi LocalSlotIndex where encode = encode . getSlotIndex decode = UnsafeLocalSlotIndex <$> decode @@ -56,8 +63,9 @@ instance Bi LocalSlotIndex where localSlotIndexMinBound :: LocalSlotIndex localSlotIndexMinBound = UnsafeLocalSlotIndex 0 -localSlotIndexMaxBound :: ProtocolConstants -> LocalSlotIndex -localSlotIndexMaxBound pc = UnsafeLocalSlotIndex (fromIntegral (pcEpochSlots pc) - 1) +localSlotIndexMaxBound :: SlotCount -> LocalSlotIndex +localSlotIndexMaxBound epochSlots = + UnsafeLocalSlotIndex (fromIntegral epochSlots - 1) -- | All local slot indices for the given number of slots in epoch, in ascending -- order. @@ -71,33 +79,26 @@ mkLocalSlotIndex_ es idx | idx < fromIntegral es = Just (UnsafeLocalSlotIndex idx) | otherwise = Nothing -mkLocalSlotIndexThrow_ :: MonadError Text m => SlotCount -> Word16 -> m LocalSlotIndex -mkLocalSlotIndexThrow_ es idx = case mkLocalSlotIndex_ es idx of +mkLocalSlotIndex :: MonadError Text m => SlotCount -> Word16 -> m LocalSlotIndex +mkLocalSlotIndex es idx = case mkLocalSlotIndex_ es idx of Just it -> pure it - Nothing -> throwError $ - "local slot is greater than or equal to the number of slots in epoch: " <> - show idx - -mkLocalSlotIndex :: (HasProtocolConstants, MonadError Text m) => Word16 -> m LocalSlotIndex -mkLocalSlotIndex = mkLocalSlotIndexThrow_ epochSlots - -mkLocalSlotIndexExplicit :: MonadError Text m => ProtocolConstants -> Word16 -> m LocalSlotIndex -mkLocalSlotIndexExplicit pc = mkLocalSlotIndexThrow_ (pcEpochSlots pc) + Nothing -> + throwError + $ "local slot is greater than or equal to the number of slots in epoch: " + <> show idx -- | Shift slot index by given amount, and return 'Nothing' if it has -- overflowed past 'epochSlots'. -addLocalSlotIndex :: HasProtocolConstants => SlotCount -> LocalSlotIndex -> Maybe LocalSlotIndex -addLocalSlotIndex x (UnsafeLocalSlotIndex i) +addLocalSlotIndex + :: SlotCount -> SlotCount -> LocalSlotIndex -> Maybe LocalSlotIndex +addLocalSlotIndex epochSlots x (UnsafeLocalSlotIndex i) | s < fromIntegral epochSlots = Just (UnsafeLocalSlotIndex (fromIntegral s)) - | otherwise = Nothing + | otherwise = Nothing where s :: Word64 s = fromIntegral x + fromIntegral i -- | Unsafe constructor of 'LocalSlotIndex'. -unsafeMkLocalSlotIndex :: HasProtocolConstants => Word16 -> LocalSlotIndex -unsafeMkLocalSlotIndex = unsafeMkLocalSlotIndexExplicit protocolConstants - -unsafeMkLocalSlotIndexExplicit :: ProtocolConstants -> Word16 -> LocalSlotIndex -unsafeMkLocalSlotIndexExplicit pc = - leftToPanic "unsafeMkLocalSlotIndex failed: " . mkLocalSlotIndexExplicit pc +unsafeMkLocalSlotIndex :: SlotCount -> Word16 -> LocalSlotIndex +unsafeMkLocalSlotIndex epochSlots = + leftToPanic "unsafeMkLocalSlotIndex failed: " . mkLocalSlotIndex epochSlots diff --git a/core/src/Pos/Core/Slotting/SlotId.hs b/core/src/Pos/Core/Slotting/SlotId.hs index 18a8608c0c8..38491e1cd12 100644 --- a/core/src/Pos/Core/Slotting/SlotId.hs +++ b/core/src/Pos/Core/Slotting/SlotId.hs @@ -4,14 +4,17 @@ module Pos.Core.Slotting.SlotId , siSlotL , slotIdF + , slotIdToEnum + , slotIdFromEnum + , slotIdSucc + , slotIdPred + , FlatSlotId , flatSlotId , flattenSlotId - , flattenSlotIdExplicit , flattenEpochIndex , unflattenSlotId - , unflattenSlotIdExplicit , crucialSlot ) where @@ -23,8 +26,8 @@ import qualified Data.Text.Buildable as Buildable import Formatting (Format, bprint, build, ords, (%)) import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) -import Pos.Core.Configuration.Protocol (HasProtocolConstants, - epochSlots, slotSecurityParam) +import Pos.Core.Common (BlockCount) +import Pos.Core.ProtocolConstants (kEpochSlots, kSlotSecurityParam) import Pos.Util.Util (leftToPanic) import Pos.Core.Slotting.EpochIndex @@ -49,9 +52,19 @@ flip makeLensesFor ''SlotId [ ("siEpoch", "siEpochL"), ("siSlot" , "siSlotL") ] -instance HasProtocolConstants => Enum SlotId where - toEnum = unflattenSlotId . fromIntegral - fromEnum = fromIntegral . flattenSlotId +slotIdToEnum :: SlotCount -> Int -> SlotId +slotIdToEnum epochSlots = unflattenSlotId epochSlots . fromIntegral + +slotIdFromEnum :: SlotCount -> SlotId -> Int +slotIdFromEnum epochSlots = fromIntegral . flattenSlotId epochSlots + +slotIdSucc :: SlotCount -> SlotId -> SlotId +slotIdSucc epochSlots = + slotIdToEnum epochSlots . (+ 1) . slotIdFromEnum epochSlots + +slotIdPred :: SlotCount -> SlotId -> SlotId +slotIdPred epochSlots = + slotIdToEnum epochSlots . subtract 1 . slotIdFromEnum epochSlots instance HasEpochIndex SlotId where epochIndexL = lens siEpoch (\s a -> s {siEpoch = a}) @@ -64,44 +77,42 @@ slotIdF = build type FlatSlotId = Word64 -- | Flatten 'SlotId' (which is basically pair of integers) into a single number. -flattenSlotId :: HasProtocolConstants => SlotId -> FlatSlotId -flattenSlotId = flattenSlotIdExplicit epochSlots - -flattenSlotIdExplicit :: SlotCount -> SlotId -> FlatSlotId -flattenSlotIdExplicit es SlotId {..} = fromIntegral $ - fromIntegral siEpoch * es + - fromIntegral (getSlotIndex siSlot) +flattenSlotId :: SlotCount -> SlotId -> FlatSlotId +flattenSlotId es SlotId {..} = + fromIntegral $ fromIntegral siEpoch * es + fromIntegral + (getSlotIndex siSlot) -- | Flattens 'EpochIndex' into a single number. -flattenEpochIndex :: HasProtocolConstants => EpochIndex -> FlatSlotId -flattenEpochIndex (EpochIndex i) = +flattenEpochIndex :: SlotCount -> EpochIndex -> FlatSlotId +flattenEpochIndex epochSlots (EpochIndex i) = fromIntegral (fromIntegral i * epochSlots) --- | Construct 'SlotId' from a flattened variant. -unflattenSlotId :: HasProtocolConstants => FlatSlotId -> SlotId -unflattenSlotId = unflattenSlotIdExplicit epochSlots - -- | Construct a 'SlotId' from a flattened variant, using a given 'SlotCount' -- modulus. -unflattenSlotIdExplicit :: SlotCount -> FlatSlotId -> SlotId -unflattenSlotIdExplicit es n = +unflattenSlotId :: SlotCount -> FlatSlotId -> SlotId +unflattenSlotId es n = let (fromIntegral -> siEpoch, fromIntegral -> slot) = n `divMod` fromIntegral es - siSlot = leftToPanic "unflattenSlotId: " $ mkLocalSlotIndexThrow_ es slot + siSlot = leftToPanic "unflattenSlotId: " $ mkLocalSlotIndex es slot in SlotId {..} -flatSlotId :: HasProtocolConstants => Iso' SlotId FlatSlotId -flatSlotId = iso flattenSlotId unflattenSlotId +flatSlotId :: SlotCount -> Iso' SlotId FlatSlotId +flatSlotId epochSlots = + iso (flattenSlotId epochSlots) (unflattenSlotId epochSlots) -- | Slot such that at the beginning of epoch blocks with SlotId ≤- this slot -- are stable. -crucialSlot :: HasProtocolConstants => EpochIndex -> SlotId -crucialSlot 0 = SlotId {siEpoch = 0, siSlot = minBound} -crucialSlot epochIdx = SlotId {siEpoch = epochIdx - 1, ..} +crucialSlot :: BlockCount -> EpochIndex -> SlotId +crucialSlot _ 0 = SlotId {siEpoch = 0, siSlot = localSlotIndexMinBound} +crucialSlot k epochIdx = SlotId {siEpoch = epochIdx - 1, siSlot = siSlot} where siSlot = - leftToPanic "crucialSlot: " $ - mkLocalSlotIndex (fromIntegral (fromIntegral epochSlots - slotSecurityParam - 1)) + leftToPanic "crucialSlot: " + . mkLocalSlotIndex (kEpochSlots k) + . fromIntegral + $ fromIntegral (kEpochSlots k) + - (kSlotSecurityParam k) + - 1 -- TH instances diff --git a/core/test/Test/Pos/Core/Arbitrary.hs b/core/test/Test/Pos/Core/Arbitrary.hs index c32aef6138c..7dd340446a6 100644 --- a/core/test/Test/Pos/Core/Arbitrary.hs +++ b/core/test/Test/Pos/Core/Arbitrary.hs @@ -53,10 +53,9 @@ import Pos.Core (AddrAttributes (..), AddrSpendingData (..), localSlotIndexMaxBound, localSlotIndexMinBound, makeAddress, maxCoinVal, mkCoin, mkLocalSlotIndex, mkMultiKeyDistr, mkVssCertificate, - mkVssCertificatesMapLossy, unsafeCoinPortionFromDouble, - unsafeGetCoin, unsafeSubCoin) -import Pos.Core.Configuration (HasGenesisBlockVersionData, - HasProtocolConstants, epochSlots, protocolConstants) + mkVssCertificatesMapLossy, pcEpochSlots, + unsafeCoinPortionFromDouble, unsafeGetCoin, unsafeSubCoin) +import Pos.Core.Configuration (HasGenesisBlockVersionData) import Pos.Core.Constants (sharedSeedLength) import Pos.Core.Delegation (HeavyDlgIndex (..), LightDlgIndices (..)) import qualified Pos.Core.Genesis as G @@ -67,6 +66,7 @@ import Pos.Data.Attributes (Attributes (..), UnparsedFields (..)) import Pos.Merkle (MerkleTree, mkMerkleTree) import Pos.Util.Util (leftToPanic) +import Test.Pos.Core.Dummy (dummyProtocolConstants) import Test.Pos.Crypto.Arbitrary () import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.Orphans () @@ -121,24 +121,24 @@ instance Arbitrary EpochIndex where arbitrary = choose (0, maxReasonableEpoch) shrink = genericShrink -genLocalSlotIndex :: ProtocolConstants -> Gen LocalSlotIndex -genLocalSlotIndex pc = UnsafeLocalSlotIndex <$> +genLocalSlotIndex :: SlotCount -> Gen LocalSlotIndex +genLocalSlotIndex epochSlots = UnsafeLocalSlotIndex <$> choose ( getSlotIndex localSlotIndexMinBound - , getSlotIndex (localSlotIndexMaxBound pc) + , getSlotIndex $ localSlotIndexMaxBound epochSlots ) -instance HasProtocolConstants => Arbitrary LocalSlotIndex where - arbitrary = genLocalSlotIndex protocolConstants +instance Arbitrary LocalSlotIndex where + arbitrary = genLocalSlotIndex $ pcEpochSlots dummyProtocolConstants shrink = genericShrink -genSlotId :: ProtocolConstants -> Gen SlotId -genSlotId pc = SlotId <$> arbitrary <*> genLocalSlotIndex pc +genSlotId :: SlotCount -> Gen SlotId +genSlotId epochSlots = SlotId <$> arbitrary <*> genLocalSlotIndex epochSlots -instance HasProtocolConstants => Arbitrary SlotId where +instance Arbitrary SlotId where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary EpochOrSlot where +instance Arbitrary EpochOrSlot where arbitrary = oneof [ EpochOrSlot . Left <$> arbitrary , EpochOrSlot . Right <$> arbitrary @@ -151,16 +151,17 @@ newtype EoSToIntOverflow = EoSToIntOverflow { getEoS :: EpochOrSlot } deriving (Show, Eq, Generic) -instance HasProtocolConstants => Arbitrary EoSToIntOverflow where +instance Arbitrary EoSToIntOverflow where arbitrary = EoSToIntOverflow <$> do - let maxIntAsInteger = toInteger (maxBound :: Int) + let epochSlots = pcEpochSlots dummyProtocolConstants + maxIntAsInteger = toInteger (maxBound :: Int) maxW64 = toInteger (maxBound :: Word64) (minDiv, minMod) = maxIntAsInteger `divMod` (fromIntegral $ succ epochSlots) maxDiv = maxW64 `div` (1 + fromIntegral epochSlots) leftEpoch <- EpochIndex . fromIntegral <$> choose (minDiv + 1, maxDiv) localSlot <- leftToPanic "arbitrary@EoSToIntOverflow" . - mkLocalSlotIndex . + mkLocalSlotIndex epochSlots . fromIntegral <$> choose (minMod, toInteger epochSlots) let rightEpoch = EpochIndex . fromIntegral $ minDiv EpochOrSlot <$> @@ -178,8 +179,9 @@ newtype UnreasonableEoS = Unreasonable { getUnreasonable :: EpochOrSlot } deriving (Show, Eq, Generic) -instance HasProtocolConstants => Arbitrary UnreasonableEoS where +instance Arbitrary UnreasonableEoS where arbitrary = Unreasonable . EpochOrSlot <$> do + let epochSlots = pcEpochSlots dummyProtocolConstants let maxI = (maxBound :: Int) `div` (1 + fromIntegral epochSlots) localSlot <- arbitrary let lsIntegral = fromIntegral . getSlotIndex $ localSlot @@ -561,7 +563,7 @@ instance Arbitrary ProtocolConstants where instance Arbitrary G.GenesisProtocolConstants where arbitrary = flip G.genesisProtocolConstantsFromProtocolConstants dummyProtocolMagic <$> arbitrary -instance (HasProtocolConstants) => Arbitrary G.GenesisData where +instance Arbitrary G.GenesisData where arbitrary = G.GenesisData <$> arbitrary <*> arbitrary <*> arbitraryStartTime <*> arbitraryVssCerts <*> arbitrary <*> arbitraryBVD diff --git a/core/test/Test/Pos/Core/Arbitrary/Unsafe.hs b/core/test/Test/Pos/Core/Arbitrary/Unsafe.hs index 0f2d818a428..348b2080084 100644 --- a/core/test/Test/Pos/Core/Arbitrary/Unsafe.hs +++ b/core/test/Test/Pos/Core/Arbitrary/Unsafe.hs @@ -9,7 +9,6 @@ import Universum import Pos.Core (AddrAttributes (..), AddrStakeDistribution (..), AddrType (..), Address (..), Coin, EpochIndex (..), LocalSlotIndex, SharedSeed (..), SlotId (..), mkCoin) -import Pos.Core.Configuration (HasProtocolConstants) import Pos.Data.Attributes (mkAttributes) import Test.Pos.Core.Arbitrary () @@ -19,7 +18,7 @@ import Test.Pos.Util.QuickCheck.Arbitrary (ArbitraryUnsafe (..)) deriving instance ArbitraryUnsafe SharedSeed deriving instance ArbitraryUnsafe EpochIndex -instance HasProtocolConstants => ArbitraryUnsafe LocalSlotIndex where +instance ArbitraryUnsafe LocalSlotIndex where instance ArbitraryUnsafe Coin where arbitraryUnsafe = mkCoin <$> arbitraryUnsafe @@ -36,5 +35,5 @@ instance ArbitraryUnsafe Address where let addrType = ATPubKey return Address {..} -instance HasProtocolConstants => ArbitraryUnsafe SlotId where +instance ArbitraryUnsafe SlotId where arbitraryUnsafe = SlotId <$> arbitraryUnsafe <*> arbitraryUnsafe diff --git a/core/test/Test/Pos/Core/Bi.hs b/core/test/Test/Pos/Core/Bi.hs index 67540008a08..52ebdcf5f57 100644 --- a/core/test/Test/Pos/Core/Bi.hs +++ b/core/test/Test/Pos/Core/Bi.hs @@ -39,7 +39,7 @@ import Pos.Core.Common (AddrAttributes (..), AddrSpendingData (..), import Pos.Core.Configuration (GenesisHash (..)) import Pos.Core.Delegation (DlgPayload (..), HeavyDlgIndex (..), LightDlgIndices (..), ProxySKBlockInfo, ProxySKHeavy) -import Pos.Core.ProtocolConstants (ProtocolConstants (..)) +import Pos.Core.ProtocolConstants (pcEpochSlots) import Pos.Core.Slotting (EpochIndex (..), EpochOrSlot (..), FlatSlotId, LocalSlotIndex (..), SlotCount (..), SlotId (..), TimeDiff (..), Timestamp (..)) @@ -108,7 +108,7 @@ golden_BlockHeaderMain = goldenTestBi exampleBlockHeaderMain "test/golden/BlockHeaderMain" roundTripBlockHeaderBi :: Property -roundTripBlockHeaderBi = eachOf 10 (feedPMC genBlockHeader) roundTripsBiBuildable +roundTripBlockHeaderBi = eachOf 10 (feedPMEpochSlots genBlockHeader) roundTripsBiBuildable -------------------------------------------------------------------------------- -- BlockHeaderAttributes @@ -135,7 +135,7 @@ golden_BlockSignature_Heavy = goldenTestBi exampleBlockPSignatureHeavy "test/golden/BlockSignature_Heavy" roundTripBlockSignatureBi :: Property -roundTripBlockSignatureBi = eachOf 10 (feedPMC genBlockSignature) roundTripsBiBuildable +roundTripBlockSignatureBi = eachOf 10 (feedPMEpochSlots genBlockSignature) roundTripsBiBuildable -------------------------------------------------------------------------------- -- GenesisBlockHeader @@ -192,7 +192,7 @@ golden_MainBlockHeader :: Property golden_MainBlockHeader = goldenTestBi exampleMainBlockHeader "test/golden/MainBlockHeader" roundTripMainBlockHeaderBi :: Property -roundTripMainBlockHeaderBi = eachOf 20 (feedPMC genMainBlockHeader) roundTripsBiBuildable +roundTripMainBlockHeaderBi = eachOf 20 (feedPMEpochSlots genMainBlockHeader) roundTripsBiBuildable -------------------------------------------------------------------------------- -- MainBody @@ -212,7 +212,7 @@ golden_MainConsensusData = goldenTestBi mcd "test/golden/MainConsensusData" exampleChainDifficulty exampleBlockSignature roundTripMainConsensusData :: Property -roundTripMainConsensusData = eachOf 20 (feedPMC genMainConsensusData) roundTripsBiShow +roundTripMainConsensusData = eachOf 20 (feedPMEpochSlots genMainConsensusData) roundTripsBiShow -------------------------------------------------------------------------------- -- MainExtraBodyData @@ -250,7 +250,7 @@ golden_MainToSign :: Property golden_MainToSign = goldenTestBi exampleMainToSign "test/golden/MainToSign" roundTripMainToSignBi :: Property -roundTripMainToSignBi = eachOf 20 (feedPMC genMainToSign) roundTripsBiShow +roundTripMainToSignBi = eachOf 20 (feedPMEpochSlots genMainToSign) roundTripsBiShow -------------------------------------------------------------------------------- -- Address @@ -558,7 +558,7 @@ golden_EpochOrSlotSI = goldenTestBi eos "test/golden/EpochOrSlotSI" where eos = EpochOrSlot (Right exampleSlotId) roundTripEpochOrSlotBi :: Property -roundTripEpochOrSlotBi = eachOf 1000 (feedPC genEpochOrSlot) roundTripsBiBuildable +roundTripEpochOrSlotBi = eachOf 1000 (feedEpochSlots genEpochOrSlot) roundTripsBiBuildable -------------------------------------------------------------------------------- -- FlatSlotId @@ -578,7 +578,7 @@ golden_LocalSlotIndex = goldenTestBi lsi "test/golden/LocalSlotIndex" where lsi = UnsafeLocalSlotIndex 52 roundTripLocalSlotIndexBi :: Property -roundTripLocalSlotIndexBi = eachOf 1000 (feedPC genLocalSlotIndex) roundTripsBiBuildable +roundTripLocalSlotIndexBi = eachOf 1000 (feedEpochSlots genLocalSlotIndex) roundTripsBiBuildable -------------------------------------------------------------------------------- -- SlotCount @@ -597,7 +597,7 @@ golden_SlotId :: Property golden_SlotId = goldenTestBi exampleSlotId "test/golden/SlotId" roundTripSlotIdBi :: Property -roundTripSlotIdBi = eachOf 1000 (feedPC genSlotId) roundTripsBiBuildable +roundTripSlotIdBi = eachOf 1000 (feedEpochSlots genSlotId) roundTripsBiBuildable -------------------------------------------------------------------------------- -- TimeDiff @@ -1241,14 +1241,14 @@ roundTripVssCertificatesMap = eachOf 10 (feedPM genVssCertificatesMap) roundTrip feedPM :: (ProtocolMagic -> H.Gen a) -> H.Gen a feedPM genA = genA =<< genProtocolMagic -feedPC :: (ProtocolConstants -> H.Gen a) -> H.Gen a -feedPC genA = genA =<< genProtocolConstants +feedEpochSlots :: (SlotCount -> H.Gen a) -> H.Gen a +feedEpochSlots genA = genA =<< pcEpochSlots <$> genProtocolConstants -feedPMC :: (ProtocolMagic -> ProtocolConstants -> H.Gen a) -> H.Gen a -feedPMC genA = do +feedPMEpochSlots :: (ProtocolMagic -> SlotCount -> H.Gen a) -> H.Gen a +feedPMEpochSlots genA = do pm <- genProtocolMagic - pc <- genProtocolConstants - genA pm pc + epochSlots <- pcEpochSlots <$> genProtocolConstants + genA pm epochSlots -------------------------------------------------------------------------------- diff --git a/core/test/Test/Pos/Core/CborSpec.hs b/core/test/Test/Pos/Core/CborSpec.hs index 844118ce85e..44abca666e1 100644 --- a/core/test/Test/Pos/Core/CborSpec.hs +++ b/core/test/Test/Pos/Core/CborSpec.hs @@ -79,7 +79,7 @@ instance Bi (Attributes X2) where spec :: Spec -spec = withGenesisSpec 0 defaultCoreConfiguration $ \_ -> +spec = withGenesisSpec 0 defaultCoreConfiguration $ \_ _ -> describe "Cbor Bi instances" $ do describe "Core.Address" $ do binaryTest @Address diff --git a/core/test/Test/Pos/Core/Dummy.hs b/core/test/Test/Pos/Core/Dummy.hs new file mode 100644 index 00000000000..6e7bdcaeeb6 --- /dev/null +++ b/core/test/Test/Pos/Core/Dummy.hs @@ -0,0 +1,26 @@ +module Test.Pos.Core.Dummy + ( dummyProtocolConstants + , dummyK + , dummyEpochSlots + , dummySlotSecurityParam + ) where + +import Pos.Core (BlockCount, ProtocolConstants (..), SlotCount, + VssMaxTTL (..), VssMinTTL (..), kEpochSlots, + kSlotSecurityParam, pcBlkSecurityParam) + +dummyProtocolConstants :: ProtocolConstants +dummyProtocolConstants = ProtocolConstants + { pcK = 10 + , pcVssMinTTL = VssMinTTL 2 + , pcVssMaxTTL = VssMaxTTL 6 + } + +dummyK :: BlockCount +dummyK = pcBlkSecurityParam dummyProtocolConstants + +dummyEpochSlots :: SlotCount +dummyEpochSlots = kEpochSlots dummyK + +dummySlotSecurityParam :: SlotCount +dummySlotSecurityParam = kSlotSecurityParam dummyK diff --git a/core/test/Test/Pos/Core/Gen.hs b/core/test/Test/Pos/Core/Gen.hs index 440dfa1310c..5d4964901d4 100644 --- a/core/test/Test/Pos/Core/Gen.hs +++ b/core/test/Test/Pos/Core/Gen.hs @@ -229,17 +229,17 @@ import Test.Pos.Crypto.Gen (genAbstractHash, genDecShare, genBlockBodyAttributes :: Gen BlockBodyAttributes genBlockBodyAttributes = pure $ mkAttributes () -genBlockHeader :: ProtocolMagic -> ProtocolConstants -> Gen BlockHeader -genBlockHeader pm pc = +genBlockHeader :: ProtocolMagic -> SlotCount -> Gen BlockHeader +genBlockHeader pm epochSlots = Gen.choice [ BlockHeaderGenesis <$> genGenesisBlockHeader pm - , BlockHeaderMain <$> genMainBlockHeader pm pc + , BlockHeaderMain <$> genMainBlockHeader pm epochSlots ] genBlockHeaderAttributes :: Gen BlockHeaderAttributes genBlockHeaderAttributes = pure $ mkAttributes () -genBlockSignature :: ProtocolMagic -> ProtocolConstants -> Gen BlockSignature -genBlockSignature pm pc = do +genBlockSignature :: ProtocolMagic -> SlotCount -> Gen BlockSignature +genBlockSignature pm epochSlots = do Gen.choice [ BlockSignature <$> genSignature pm mts @@ -249,7 +249,7 @@ genBlockSignature pm pc = do <$> genProxySignature pm mts genHeavyDlgIndex ] where - mts = genMainToSign pm pc + mts = genMainToSign pm epochSlots genGenesisBlockHeader :: ProtocolMagic -> Gen GenesisBlockHeader genGenesisBlockHeader pm = do @@ -292,24 +292,24 @@ genMainBody pm = -- We use `Nothing` as the ProxySKBlockInfo to avoid clashing key errors -- (since we use example keys which aren't related to each other) -genMainBlockHeader :: ProtocolMagic -> ProtocolConstants -> Gen MainBlockHeader -genMainBlockHeader pm pc = +genMainBlockHeader :: ProtocolMagic -> SlotCount -> Gen MainBlockHeader +genMainBlockHeader pm epochSlots = mkMainHeaderExplicit pm <$> genHeaderHash <*> genChainDifficulty - <*> genSlotId pc + <*> genSlotId epochSlots <*> genSecretKey <*> pure Nothing <*> genMainBody pm <*> genMainExtraHeaderData -genMainConsensusData :: ProtocolMagic -> ProtocolConstants -> Gen MainConsensusData -genMainConsensusData pm pc = +genMainConsensusData :: ProtocolMagic -> SlotCount -> Gen MainConsensusData +genMainConsensusData pm epochSlots = MainConsensusData - <$> genSlotId pc + <$> genSlotId epochSlots <*> genPublicKey <*> genChainDifficulty - <*> genBlockSignature pm pc + <*> genBlockSignature pm epochSlots genMainExtraBodyData :: Gen MainExtraBodyData @@ -331,12 +331,12 @@ genMainProof pm = <*> genAbstractHash (genDlgPayload pm) <*> genUpdateProof pm -genMainToSign :: ProtocolMagic -> ProtocolConstants -> Gen MainToSign -genMainToSign pm pc = +genMainToSign :: ProtocolMagic -> SlotCount -> Gen MainToSign +genMainToSign pm epochSlots = MainToSign - <$> genAbstractHash (genBlockHeader pm pc) + <$> genAbstractHash (genBlockHeader pm epochSlots) <*> genMainProof pm - <*> genSlotId pc + <*> genSlotId epochSlots <*> genChainDifficulty <*> genMainExtraHeaderData @@ -601,26 +601,27 @@ genVssMinTTL = VssMinTTL <$> genWord32 genEpochIndex :: Gen EpochIndex genEpochIndex = EpochIndex <$> Gen.word64 Range.constantBounded -genEpochOrSlot :: ProtocolConstants -> Gen EpochOrSlot -genEpochOrSlot pc = +genEpochOrSlot :: SlotCount -> Gen EpochOrSlot +genEpochOrSlot epochSlots = Gen.choice [ EpochOrSlot . Left <$> genEpochIndex - , EpochOrSlot . Right <$> genSlotId pc + , EpochOrSlot . Right <$> genSlotId epochSlots ] genFlatSlotId :: Gen FlatSlotId genFlatSlotId = Gen.word64 Range.constantBounded -genLocalSlotIndex :: ProtocolConstants -> Gen LocalSlotIndex -genLocalSlotIndex pc = UnsafeLocalSlotIndex <$> Gen.word16 (Range.constant lb ub) +genLocalSlotIndex :: SlotCount -> Gen LocalSlotIndex +genLocalSlotIndex epochSlots = + UnsafeLocalSlotIndex <$> Gen.word16 (Range.constant lb ub) where lb = getSlotIndex (localSlotIndexMinBound) - ub = getSlotIndex (localSlotIndexMaxBound pc) + ub = getSlotIndex (localSlotIndexMaxBound epochSlots) genSlotCount :: Gen SlotCount genSlotCount = SlotCount <$> Gen.word64 Range.constantBounded -genSlotId :: ProtocolConstants -> Gen SlotId -genSlotId pc = SlotId <$> genEpochIndex <*> genLocalSlotIndex pc +genSlotId :: SlotCount -> Gen SlotId +genSlotId epochSlots = SlotId <$> genEpochIndex <*> genLocalSlotIndex epochSlots genTimeDiff :: Gen TimeDiff genTimeDiff = TimeDiff <$> genMicrosecond diff --git a/core/test/Test/Pos/Core/SlottingSpec.hs b/core/test/Test/Pos/Core/SlottingSpec.hs index e320f75d13d..9781ea53841 100644 --- a/core/test/Test/Pos/Core/SlottingSpec.hs +++ b/core/test/Test/Pos/Core/SlottingSpec.hs @@ -11,16 +11,18 @@ import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (NonNegative (..), Positive (..), Property, (===), (==>)) -import Pos.Core (EpochOrSlot, HasConfiguration, SlotId (..), - defaultCoreConfiguration, flattenSlotId, unflattenSlotId, - withGenesisSpec) +import Pos.Core (EpochOrSlot, SlotId (..), epochOrSlotFromEnum, + epochOrSlotMaxBound, epochOrSlotMinBound, epochOrSlotPred, + epochOrSlotSucc, epochOrSlotToEnum, flattenSlotId, + unflattenSlotId) import Test.Pos.Core.Arbitrary (EoSToIntOverflow (..), UnreasonableEoS (..)) +import Test.Pos.Core.Dummy (dummyEpochSlots) import Test.Pos.Util.QuickCheck.Property (shouldThrowException, (.=.)) spec :: Spec -spec = withGenesisSpec 0 defaultCoreConfiguration $ \_ -> describe "Slotting" $ do +spec = describe "Slotting" $ do describe "SlotId" $ do describe "Ord" $ do prop "is consistent with flatten/unflatten" @@ -46,40 +48,65 @@ spec = withGenesisSpec 0 defaultCoreConfiguration $ \_ -> describe "Slotting" $ prop "calling 'toEnum' with a negative number will raise an exception" toEnumNegative -flattenOrdConsistency :: HasConfiguration => SlotId -> SlotId -> Property -flattenOrdConsistency a b = a `compare` b === flattenSlotId a `compare` flattenSlotId b - -flattenThenUnflatten :: HasConfiguration => SlotId -> Property -flattenThenUnflatten si = si === unflattenSlotId (flattenSlotId si) - -predThenSucc :: HasConfiguration => EpochOrSlot -> Property -predThenSucc eos = eos > minBound ==> succ (pred eos) === eos - -predToMinBound :: HasConfiguration => Expectation -predToMinBound = - shouldThrowException pred anyErrorCall (minBound :: EpochOrSlot) - -succThenPred :: HasConfiguration => EpochOrSlot -> Property -succThenPred eos = eos < maxBound ==> pred (succ eos) === eos - -succToMaxBound :: HasConfiguration => Expectation -succToMaxBound = shouldThrowException succ anyErrorCall (maxBound :: EpochOrSlot) +flattenOrdConsistency :: SlotId -> SlotId -> Property +flattenOrdConsistency a b = + a + `compare` b + === flattenSlotId dummyEpochSlots a + `compare` flattenSlotId dummyEpochSlots b + +flattenThenUnflatten :: SlotId -> Property +flattenThenUnflatten si = + si === unflattenSlotId dummyEpochSlots (flattenSlotId dummyEpochSlots si) + +predThenSucc :: EpochOrSlot -> Property +predThenSucc eos = + eos + > epochOrSlotMinBound + ==> epochOrSlotSucc dummyEpochSlots + (epochOrSlotPred dummyEpochSlots eos) + === eos + +predToMinBound :: Expectation +predToMinBound = shouldThrowException (epochOrSlotPred dummyEpochSlots) + anyErrorCall + epochOrSlotMinBound + +succThenPred :: EpochOrSlot -> Property +succThenPred eos = + eos + < epochOrSlotMaxBound dummyEpochSlots + ==> epochOrSlotPred dummyEpochSlots + (epochOrSlotSucc dummyEpochSlots eos) + === eos + +succToMaxBound :: Expectation +succToMaxBound = shouldThrowException (epochOrSlotSucc dummyEpochSlots) + anyErrorCall + (epochOrSlotMaxBound dummyEpochSlots) -- It is not necessary to check that 'int < fromEnum (maxBound :: EpochOrSlot)' because -- this is not possible with the current implementation of the type. -toFromEnum :: HasConfiguration => NonNegative Int -> Property -toFromEnum (getNonNegative -> int) = fromEnum (toEnum @EpochOrSlot int) === int - -fromToEnum :: HasConfiguration => EpochOrSlot -> Property -fromToEnum = toEnum . fromEnum .=. identity - -fromToEnumLargeEpoch :: HasConfiguration => UnreasonableEoS -> Property -fromToEnumLargeEpoch (getUnreasonable -> eos) = toEnum (fromEnum eos) === eos - -fromEnumOverflow :: HasConfiguration => EoSToIntOverflow-> Expectation +toFromEnum :: NonNegative Int -> Property +toFromEnum (getNonNegative -> int) = + epochOrSlotFromEnum dummyEpochSlots (epochOrSlotToEnum dummyEpochSlots int) + === int + +fromToEnum :: EpochOrSlot -> Property +fromToEnum = + epochOrSlotToEnum dummyEpochSlots + . epochOrSlotFromEnum dummyEpochSlots + .=. identity + +fromToEnumLargeEpoch :: UnreasonableEoS -> Property +fromToEnumLargeEpoch (getUnreasonable -> eos) = + epochOrSlotToEnum dummyEpochSlots (epochOrSlotFromEnum dummyEpochSlots eos) + === eos + +fromEnumOverflow :: EoSToIntOverflow -> Expectation fromEnumOverflow (getEoS -> eos) = - shouldThrowException (fromEnum @EpochOrSlot) anyErrorCall eos + shouldThrowException (epochOrSlotFromEnum dummyEpochSlots) anyErrorCall eos -toEnumNegative :: HasConfiguration => Positive Int -> Expectation +toEnumNegative :: Positive Int -> Expectation toEnumNegative (negate . getPositive -> int) = - shouldThrowException (toEnum @EpochOrSlot) anyErrorCall int + shouldThrowException (epochOrSlotToEnum dummyEpochSlots) anyErrorCall int diff --git a/core/test/cardano-sl-core-test.cabal b/core/test/cardano-sl-core-test.cabal index 092eda1716e..10768ba94e8 100644 --- a/core/test/cardano-sl-core-test.cabal +++ b/core/test/cardano-sl-core-test.cabal @@ -19,6 +19,7 @@ library Test.Pos.Core.Gen Test.Pos.Core.Arbitrary Test.Pos.Core.Arbitrary.Unsafe + Test.Pos.Core.Dummy build-depends: QuickCheck , base diff --git a/explorer/bench/Bench/Pos/Explorer/ServerBench.hs b/explorer/bench/Bench/Pos/Explorer/ServerBench.hs index 6f7c7086345..5c644ad7456 100644 --- a/explorer/bench/Bench/Pos/Explorer/ServerBench.hs +++ b/explorer/bench/Bench/Pos/Explorer/ServerBench.hs @@ -21,6 +21,7 @@ import Pos.Explorer.Web.ClientTypes (CBlockEntry) import Pos.Explorer.Web.Server (getBlocksPage, getBlocksTotal) import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Core.Dummy (dummyEpochSlots) import Test.Pos.Txp.Arbitrary.Unsafe () ---------------------------------------------------------------- @@ -32,7 +33,7 @@ type BenchmarkTestParams = (ExplorerTestParams, ExtraContext) -- | @getBlocksTotal@ function for benchmarks. getBlocksTotalBench :: BenchmarkTestParams -> IO Integer getBlocksTotalBench (testParams, extraContext) = - withDefConfigurations $ const . const $ runExplorerTestMode + withDefConfigurations $ const $ runExplorerTestMode testParams extraContext getBlocksTotal @@ -42,9 +43,10 @@ getBlocksPageBench :: BenchmarkTestParams -> IO (Integer, [CBlockEntry]) getBlocksPageBench (testParams, extraContext) = withDefConfigurations $ const - . const $ runExplorerTestMode testParams extraContext - $ getBlocksPage Nothing (Just $ fromIntegral defaultPageSize) + $ getBlocksPage dummyEpochSlots + Nothing + (Just $ fromIntegral defaultPageSize) -- | This is used to generate the test environment. We don't do this while benchmarking -- the functions since that would include the time/memory required for the generation of the @@ -61,7 +63,7 @@ generateTestParams totalBlocksNumber slotsPerEpoch = do -- The extra context so we can mock the functions. let extraContext :: ExtraContext - extraContext = withDefConfigurations $ const . const $ makeMockExtraCtx mode + extraContext = withDefConfigurations $ const $ makeMockExtraCtx mode pure (testParams, extraContext) where diff --git a/explorer/cardano-sl-explorer.cabal b/explorer/cardano-sl-explorer.cabal index 5aa4d84a1c3..5f81702f58b 100644 --- a/explorer/cardano-sl-explorer.cabal +++ b/explorer/cardano-sl-explorer.cabal @@ -355,6 +355,7 @@ test-suite cardano-explorer-test , cardano-sl-block , cardano-sl-block-test , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto , cardano-sl-explorer , cardano-sl-txp @@ -413,6 +414,7 @@ benchmark cardano-explorer-bench build-depends: QuickCheck , base , cardano-sl + , cardano-sl-core-test , cardano-sl-explorer , cardano-sl-txp , cardano-sl-txp-test diff --git a/explorer/src/Pos/Explorer/BListener.hs b/explorer/src/Pos/Explorer/BListener.hs index 5c9e5be5296..b23e91df17c 100644 --- a/explorer/src/Pos/Explorer/BListener.hs +++ b/explorer/src/Pos/Explorer/BListener.hs @@ -78,8 +78,8 @@ instance ( MonadDBRead m , HasConfiguration ) => MonadBListener (ExplorerBListener m) where - onApplyBlocks blunds = onApplyCallGeneral blunds - onRollbackBlocks blunds = onRollbackCallGeneral blunds + onApplyBlocks blunds = onApplyCallGeneral blunds + onRollbackBlocks _ blunds = onRollbackCallGeneral blunds ---------------------------------------------------------------------------- diff --git a/explorer/src/Pos/Explorer/DB.hs b/explorer/src/Pos/Explorer/DB.hs index de16b68dd0e..a52f7829cf6 100644 --- a/explorer/src/Pos/Explorer/DB.hs +++ b/explorer/src/Pos/Explorer/DB.hs @@ -43,7 +43,8 @@ import UnliftIO (MonadUnliftIO) import Pos.Binary.Class (serialize') import Pos.Core (Address, Coin, EpochIndex (..), HasConfiguration, - HeaderHash, SlotCount, coinToInteger, unsafeAddCoin) + HeaderHash, ProtocolConstants, coinToInteger, + unsafeAddCoin) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Txp (Tx, TxId, TxOut (..), TxOutAux (..)) import Pos.Crypto (ProtocolMagic) @@ -58,16 +59,13 @@ import Pos.Txp.GenesisUtxo (genesisUtxo) import Pos.Txp.Toil (GenesisUtxo (..), utxoF, utxoToAddressCoinPairs) import Pos.Util.Util (maybeThrow) - - explorerInitDB - :: forall ctx m. - ( MonadReader ctx m - , MonadUnliftIO m - , MonadDB m - ) - => ProtocolMagic -> SlotCount -> m () -explorerInitDB pm epochSlots = initNodeDBs pm epochSlots >> prepareExplorerDB + :: forall ctx m + . (MonadReader ctx m, MonadUnliftIO m, MonadDB m) + => ProtocolMagic + -> ProtocolConstants + -> m () +explorerInitDB pm pc = initNodeDBs pm pc >> prepareExplorerDB ---------------------------------------------------------------------------- -- Types diff --git a/explorer/src/Pos/Explorer/ExplorerMode.hs b/explorer/src/Pos/Explorer/ExplorerMode.hs index 8e85b4ca831..ba6f9482213 100644 --- a/explorer/src/Pos/Explorer/ExplorerMode.hs +++ b/explorer/src/Pos/Explorer/ExplorerMode.hs @@ -24,7 +24,7 @@ import Test.QuickCheck (Gen, Property, Testable (..), arbitrary, import Test.QuickCheck.Monadic (PropertyM, monadic) import Pos.Block.Slog (mkSlogGState) -import Pos.Core (SlotId, Timestamp (..), epochSlots) +import Pos.Core (SlotId, Timestamp (..)) import Pos.DB (MonadGState (..)) import qualified Pos.DB as DB import qualified Pos.DB.Block as DB @@ -60,6 +60,7 @@ import Pos.WorkMode (MinWorkMode) import Test.Pos.Block.Logic.Emulation (Emulation (..), runEmulation) import Test.Pos.Block.Logic.Mode (TestParams (..)) +import Test.Pos.Core.Dummy (dummyEpochSlots, dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) @@ -148,13 +149,13 @@ initExplorerTestContext tp@TestParams {..} = do { eticDBPureVar = dbPureVar } liftIO $ runTestInitMode initCtx $ do - DB.initNodeDBs dummyProtocolMagic epochSlots + DB.initNodeDBs dummyProtocolMagic dummyProtocolConstants lcLrcSync <- newTVarIO =<< mkLrcSyncData let _gscLrcContext = LrcContext {..} _gscSlogGState <- mkSlogGState _gscSlottingVar <- newTVarIO =<< GS.getSlottingData let etcGState = GS.GStateContext {_gscDB = DB.PureDB dbPureVar, ..} - etcSSlottingVar <- mkSimpleSlottingStateVar + etcSSlottingVar <- mkSimpleSlottingStateVar dummyEpochSlots etcSystemStart <- Timestamp <$> currentTime etcTxpLocalData <- mkTxpLocalData @@ -241,20 +242,20 @@ instance HasJsonLogConfig ExplorerTestContext where instance HasConfigurations => MonadGState ExplorerTestMode where gsAdoptedBVData = DB.gsAdoptedBVDataDefault -instance (HasConfigurations, MonadSlotsData ctx ExplorerTestMode) +instance MonadSlotsData ctx ExplorerTestMode => MonadSlots ctx ExplorerTestMode where - getCurrentSlot = do + getCurrentSlot epochSlots = do view etcSlotId_L >>= \case - Nothing -> Slot.getCurrentSlotSimple + Nothing -> Slot.getCurrentSlotSimple epochSlots Just slot -> pure (Just slot) - getCurrentSlotBlocking = + getCurrentSlotBlocking epochSlots = view etcSlotId_L >>= \case - Nothing -> Slot.getCurrentSlotBlockingSimple + Nothing -> Slot.getCurrentSlotBlockingSimple epochSlots Just slot -> pure slot - getCurrentSlotInaccurate = do + getCurrentSlotInaccurate epochSlots = do view etcSlotId_L >>= \case - Nothing -> Slot.getCurrentSlotInaccurateSimple + Nothing -> Slot.getCurrentSlotInaccurateSimple epochSlots Just slot -> pure slot currentTimeSlotting = Slot.currentTimeSlottingSimple diff --git a/explorer/src/Pos/Explorer/Socket/App.hs b/explorer/src/Pos/Explorer/Socket/App.hs index a763775e3c6..00aacc212b9 100644 --- a/explorer/src/Pos/Explorer/Socket/App.hs +++ b/explorer/src/Pos/Explorer/Socket/App.hs @@ -40,7 +40,7 @@ import System.Wlog (CanLog, HasLoggerName, LoggerName, logInfo, logWarning, modifyLoggerName, usingLoggerName) import Pos.Block.Types (Blund) -import Pos.Core (addressF, siEpoch) +import Pos.Core (SlotCount, addressF, siEpoch) import qualified Pos.GState as DB import Pos.Infra.Slotting (MonadSlots (getCurrentSlot)) @@ -161,10 +161,8 @@ notifierServer notifierSettings connVar = do "404 - Not Found" periodicPollChanges - :: forall ctx m. - (ExplorerMode ctx m) - => ConnectionsVar -> m () -periodicPollChanges connVar = + :: forall ctx m . ExplorerMode ctx m => SlotCount -> ConnectionsVar -> m () +periodicPollChanges epochSlots connVar = -- Runs every 5 seconds. runPeriodically (5000 :: Millisecond) (Nothing, mempty) $ do curBlock <- DB.getTip @@ -189,10 +187,10 @@ periodicPollChanges connVar = -- notify changes depending on new blocks unless (null newBlunds) $ do -- 1. last page of blocks - notifyBlocksLastPageSubscribers + notifyBlocksLastPageSubscribers epochSlots -- 2. last page of epochs - mSlotId <- lift $ getCurrentSlot @ctx - whenJust mSlotId $ notifyEpochsLastPageSubscribers . siEpoch + mSlotId <- lift $ getCurrentSlot @ctx epochSlots + whenJust mSlotId $ notifyEpochsLastPageSubscribers epochSlots . siEpoch logDebug $ sformat ("Blockchain updated ("%int%" blocks)") (length newBlunds) @@ -217,11 +215,14 @@ periodicPollChanges connVar = -- | Starts notification server. Kill current thread to stop it. notifierApp - :: forall ctx m. - (ExplorerMode ctx m) - => NotifierSettings -> m () -notifierApp settings = modifyLoggerName (<> "notifier.socket-io") $ do - logInfo "Starting" - connVar <- liftIO $ STM.newTVarIO mkConnectionsState - withAsync (periodicPollChanges connVar) - (\_async -> notifierServer settings connVar) + :: forall ctx m + . ExplorerMode ctx m + => SlotCount + -> NotifierSettings + -> m () +notifierApp epochSlots settings = + modifyLoggerName (<> "notifier.socket-io") $ do + logInfo "Starting" + connVar <- liftIO $ STM.newTVarIO mkConnectionsState + withAsync (periodicPollChanges epochSlots connVar) + (\_async -> notifierServer settings connVar) diff --git a/explorer/src/Pos/Explorer/Socket/Methods.hs b/explorer/src/Pos/Explorer/Socket/Methods.hs index 7c7a5d409ee..51662f44b64 100644 --- a/explorer/src/Pos/Explorer/Socket/Methods.hs +++ b/explorer/src/Pos/Explorer/Socket/Methods.hs @@ -65,7 +65,7 @@ import Network.EngineIO (SocketId) import Network.SocketIO (Socket, socketId) import qualified Pos.Block.Logic as DB import Pos.Block.Types (Blund) -import Pos.Core (Address, HeaderHash) +import Pos.Core (Address, HeaderHash, SlotCount) import Pos.Core.Block (Block, mainBlockTxPayload) import Pos.Core.Chrono (getOldestFirst) import Pos.Core.Txp (Tx (..), TxOut (..), TxOutAux (..), txOutAddress, @@ -330,11 +330,10 @@ notifyAddrSubscribers addr cTxEntries = do whenJust mRecipients $ broadcast @ctx AddrUpdated cTxEntries notifyBlocksLastPageSubscribers - :: forall ctx m . ExplorerMode ctx m - => ExplorerSockets m () -notifyBlocksLastPageSubscribers = do + :: forall ctx m . ExplorerMode ctx m => SlotCount -> ExplorerSockets m () +notifyBlocksLastPageSubscribers epochSlots = do recipients <- view csBlocksPageSubscribers - blocks <- lift $ getBlocksLastPage @ctx + blocks <- lift $ getBlocksLastPage @ctx epochSlots broadcast @ctx BlocksLastPageUpdated blocks recipients notifyTxsSubscribers @@ -344,15 +343,18 @@ notifyTxsSubscribers cTxEntries = view csTxsSubscribers >>= broadcast @ctx TxsUpdated cTxEntries notifyEpochsLastPageSubscribers - :: forall ctx m . ExplorerMode ctx m - => EpochIndex -> ExplorerSockets m () -notifyEpochsLastPageSubscribers currentEpoch = do + :: forall ctx m + . ExplorerMode ctx m + => SlotCount + -> EpochIndex + -> ExplorerSockets m () +notifyEpochsLastPageSubscribers epochSlots currentEpoch = do -- subscriber recipients <- view $ csEpochsLastPageSubscribers -- last epoch page lastPage <- lift $ getEpochPagesOrThrow currentEpoch -- epochs of last page - epochs <- lift $ getEpochPage @ctx currentEpoch $ Just lastPage + epochs <- lift $ getEpochPage @ctx epochSlots currentEpoch $ Just lastPage broadcast @ctx EpochsLastPageUpdated epochs recipients -- * Helpers diff --git a/explorer/src/Pos/Explorer/TestUtil.hs b/explorer/src/Pos/Explorer/TestUtil.hs index 17f188c986f..9fa3459c132 100644 --- a/explorer/src/Pos/Explorer/TestUtil.hs +++ b/explorer/src/Pos/Explorer/TestUtil.hs @@ -45,7 +45,7 @@ import Pos.Core.Block.Constructors (mkGenesisBlock) import Pos.Core.Ssc (SscPayload) import Pos.Core.Txp (TxAux) import Pos.Core.Update (UpdatePayload (..)) -import Pos.Crypto (ProtocolMagic, SecretKey, toPublic) +import Pos.Crypto (SecretKey, toPublic) import Pos.Delegation (DlgPayload, DlgUndo (..), ProxySKBlockInfo) import Pos.Explorer.BListener (createPagedHeaderHashesPair) import Pos.Explorer.DB (Epoch, EpochPagedBlocksKey, Page, @@ -56,6 +56,7 @@ import Pos.Update.Configuration (HasUpdateConfiguration) import Test.Pos.Block.Arbitrary () import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Core.Dummy (dummyK) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) @@ -85,7 +86,7 @@ generateValidExplorerMockableMode blocksNumber slotsPerEpoch = do slotLeaders <- produceSlotLeaders blocksNumber secretKeys <- produceSecretKeys blocksNumber - blocks <- withDefConfigurations $ \_ _ -> + blocks <- withDefConfigurations $ \_ -> produceBlocksByBlockNumberAndSlots blocksNumber slotsPerEpoch slotLeaders secretKeys let tipBlock = Prelude.last blocks @@ -105,12 +106,12 @@ generateValidExplorerMockableMode blocksNumber slotsPerEpoch = do } where - createMapPageHHs :: [Block] -> ProtocolMagic -> Map Page [HeaderHash] - createMapPageHHs blocks _ = + createMapPageHHs :: [Block] -> Map Page [HeaderHash] + createMapPageHHs blocks = fromListWith (++) [ (page, [hHash]) | (page, hHash) <- createPagedHeaderHashesPair blocks] - createMapHHsBlund :: [Block] -> ProtocolMagic -> Map HeaderHash Blund - createMapHHsBlund blocks _ = fromList $ map blockHH blocks + createMapHHsBlund :: [Block] -> Map HeaderHash Blund + createMapHHsBlund blocks = fromList $ map blockHH blocks where blockHH :: Block -> (HeaderHash, Blund) blockHH block = (headerHash block, (block, createEmptyUndo)) @@ -119,9 +120,8 @@ generateValidExplorerMockableMode blocksNumber slotsPerEpoch = do createMapEpochPageHHs :: [Block] -> SlotsPerEpoch - -> ProtocolMagic -> Map EpochPagedBlocksKey [HeaderHash] - createMapEpochPageHHs blocks slotsPerEpoch' _ = + createMapEpochPageHHs blocks slotsPerEpoch' = unions $ map convertToPagedMap epochBlock where epochBlock :: [(EpochIndex, [HeaderHash])] @@ -141,9 +141,8 @@ generateValidExplorerMockableMode blocksNumber slotsPerEpoch = do createMapEpochMaxPages :: [EpochPagedBlocksKey] - -> ProtocolMagic -> Map Epoch Page - createMapEpochMaxPages epochPages _ = do + createMapEpochMaxPages epochPages = do let groupedEpochPages :: [[(Epoch, Page)]] groupedEpochPages = groupBy ((==) `on` fst) epochPages @@ -178,17 +177,14 @@ generateValidBlocksSlotsNumber = do ---------------------------------------------------------------- basicBlockGenericUnsafe - :: (HasConfiguration, HasUpdateConfiguration) - => BlockHeader - -> SecretKey - -> SlotId - -> Block -basicBlockGenericUnsafe prevHeader sk slotId = case (basicBlock prevHeader sk slotId) of - Left e -> error e - Right block -> Right block + :: HasUpdateConfiguration => BlockHeader -> SecretKey -> SlotId -> Block +basicBlockGenericUnsafe prevHeader sk slotId = + case (basicBlock prevHeader sk slotId) of + Left e -> error e + Right block -> Right block basicBlock - :: (HasConfiguration, HasUpdateConfiguration) + :: HasUpdateConfiguration => BlockHeader -> SecretKey -> SlotId @@ -204,7 +200,7 @@ basicBlock prevHeader sk slotId = producePureBlock infLimit sk emptyBlk - :: (HasConfiguration, HasUpdateConfiguration, Testable p) + :: (HasUpdateConfiguration, Testable p) => (Either Text MainBlock -> p) -> Property emptyBlk testableBlock = @@ -220,14 +216,14 @@ emptyBlk testableBlock = def sk -defGTP :: HasConfiguration => SlotId -> SscPayload -defGTP sId = defaultSscPayload $ siSlot sId +defGTP :: SlotId -> SscPayload +defGTP sId = defaultSscPayload dummyK $ siSlot sId infLimit :: Byte infLimit = convertUnit @Gigabyte @Byte 1 producePureBlock - :: (HasConfiguration, HasUpdateConfiguration) + :: HasUpdateConfiguration => Byte -> BlockHeader -> [TxAux] @@ -239,7 +235,7 @@ producePureBlock -> SecretKey -> Either Text MainBlock producePureBlock limit prev txs psk slot dlgPay sscPay usPay sk = - createMainBlockPure dummyProtocolMagic limit prev psk slot sk $ + createMainBlockPure dummyProtocolMagic dummyK limit prev psk slot sk $ RawPayload txs sscPay dlgPay usPay leftToCounter :: (ToString s, Testable p) => Either s a -> (a -> p) -> Property diff --git a/explorer/src/Pos/Explorer/Txp/Global.hs b/explorer/src/Pos/Explorer/Txp/Global.hs index 4407417ef4e..4c45db597e4 100644 --- a/explorer/src/Pos/Explorer/Txp/Global.hs +++ b/explorer/src/Pos/Explorer/Txp/Global.hs @@ -9,7 +9,8 @@ import Universum import qualified Data.HashMap.Strict as HM import Pos.Core (ComponentBlock (..), HasConfiguration, HeaderHash, - SlotId (..), epochIndexL, headerHash, headerSlotL) + SlotId (..), epochIndexL, headerHash, headerSlotL, + localSlotIndexMinBound) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Txp (TxAux, TxUndo) import Pos.Crypto (ProtocolMagic) @@ -57,9 +58,11 @@ rollbackSettings = , pbsIsRollback = True } -applySingle :: - forall ctx m. (HasConfiguration, TxpGlobalApplyMode ctx m) - => TxpBlund -> m (EGlobalToilM ()) +applySingle + :: forall ctx m + . TxpGlobalApplyMode ctx m + => TxpBlund + -> m (EGlobalToilM ()) applySingle txpBlund = do -- @TxpBlund@ is a block/blund with a reduced set of information required for -- transaction processing. We use it to determine at which slot did a transaction @@ -74,7 +77,7 @@ applySingle txpBlund = do let slotId = case txpBlock of ComponentBlockGenesis genesisBlock -> SlotId { siEpoch = genesisBlock ^. epochIndexL - , siSlot = minBound + , siSlot = localSlotIndexMinBound -- Genesis block doesn't have a slot, set to minBound } ComponentBlockMain mainHeader _ -> mainHeader ^. headerSlotL diff --git a/explorer/src/Pos/Explorer/Txp/Local.hs b/explorer/src/Pos/Explorer/Txp/Local.hs index 09b6454b2b2..03b228a82ac 100644 --- a/explorer/src/Pos/Explorer/Txp/Local.hs +++ b/explorer/src/Pos/Explorer/Txp/Local.hs @@ -13,7 +13,7 @@ import Universum import qualified Data.HashMap.Strict as HM -import Pos.Core (BlockVersionData, EpochIndex, Timestamp) +import Pos.Core (BlockVersionData, EpochIndex, SlotCount, Timestamp) import Pos.Core.Txp (TxAux (..), TxId) import Pos.Crypto (ProtocolMagic) import Pos.Infra.Slotting (MonadSlots (getCurrentSlot), getSlotStart) @@ -40,36 +40,44 @@ type ETxpLocalWorkMode ctx m = , MempoolExt m ~ ExplorerExtraModifier ) -eTxProcessTransaction :: - ( ETxpLocalWorkMode ctx m +eTxProcessTransaction + :: ( ETxpLocalWorkMode ctx m , HasLens' ctx StateLock , HasLens' ctx (StateLockMetrics MemPoolModifyReason) , CanJsonLog m ) => ProtocolMagic + -> SlotCount -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -eTxProcessTransaction pm itw = - withStateLock LowPriority ProcessTransaction $ \__tip -> eTxProcessTransactionNoLock pm itw +eTxProcessTransaction pm epochSlots itw = + withStateLock LowPriority ProcessTransaction + $ \__tip -> eTxProcessTransactionNoLock pm epochSlots itw -eTxProcessTransactionNoLock :: - forall ctx m. (ETxpLocalWorkMode ctx m) +eTxProcessTransactionNoLock + :: forall ctx m + . (ETxpLocalWorkMode ctx m) => ProtocolMagic + -> SlotCount -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -eTxProcessTransactionNoLock pm itw = getCurrentSlot >>= \case - Nothing -> pure $ Left ToilSlotUnknown - Just slot -> do - -- First get the current @SlotId@ so we can calculate the time. - -- Then get when that @SlotId@ started and use that as a time for @Tx@. - mTxTimestamp <- getSlotStart slot - txProcessTransactionAbstract buildContext (processTx' mTxTimestamp) itw +eTxProcessTransactionNoLock pm epochSlots itw = + getCurrentSlot epochSlots >>= \case + Nothing -> pure $ Left ToilSlotUnknown + Just slot -> do + -- First get the current @SlotId@ so we can calculate the time. Then + -- get when that @SlotId@ started and use that as a time for @Tx@. + mTxTimestamp <- getSlotStart slot + txProcessTransactionAbstract epochSlots + buildContext + (processTx' mTxTimestamp) + itw where buildContext :: Utxo -> TxAux -> m ExplorerExtraLookup buildContext utxo = buildExplorerExtraLookup utxo . one - processTx' :: - Maybe Timestamp + processTx' + :: Maybe Timestamp -> BlockVersionData -> EpochIndex -> (TxId, TxAux) @@ -81,17 +89,26 @@ eTxProcessTransactionNoLock pm itw = getCurrentSlot >>= \case -- 2. Remove invalid transactions from MemPool -- 3. Set new tip to txp local data eTxNormalize - :: forall ctx m . (ETxpLocalWorkMode ctx m) => ProtocolMagic -> m () -eTxNormalize pm = do - extras <- MM.insertionsMap . view eemLocalTxsExtra <$> withTxpLocalData getTxpExtra - txNormalizeAbstract buildExplorerExtraLookup (normalizeToil' extras) + :: forall ctx m + . (ETxpLocalWorkMode ctx m) + => ProtocolMagic + -> SlotCount + -> m () +eTxNormalize pm epochSlots = do + extras <- + MM.insertionsMap + . view eemLocalTxsExtra + <$> withTxpLocalData getTxpExtra + txNormalizeAbstract epochSlots + buildExplorerExtraLookup + (normalizeToil' extras) where - normalizeToil' :: - HashMap TxId TxExtra + normalizeToil' + :: HashMap TxId TxExtra -> BlockVersionData -> EpochIndex -> HashMap TxId TxAux -> ELocalToilM () normalizeToil' extras bvd epoch txs = let toNormalize = HM.toList $ HM.intersectionWith (,) txs extras - in eNormalizeToil pm bvd epoch toNormalize + in eNormalizeToil pm bvd epoch toNormalize diff --git a/explorer/src/Pos/Explorer/Web/ClientTypes.hs b/explorer/src/Pos/Explorer/Web/ClientTypes.hs index 7d8b52149f6..6b3ae07fb4e 100644 --- a/explorer/src/Pos/Explorer/Web/ClientTypes.hs +++ b/explorer/src/Pos/Explorer/Web/ClientTypes.hs @@ -68,7 +68,7 @@ import Test.QuickCheck (Arbitrary (..)) import Pos.Binary (biSize) import Pos.Block.Types (Undo (..)) -import Pos.Core (Address, Coin, EpochIndex, LocalSlotIndex, +import Pos.Core (Address, Coin, EpochIndex, LocalSlotIndex, SlotCount, SlotId (..), StakeholderId, Timestamp, addressF, coinToInteger, decodeTextAddress, gbHeader, gbhConsensus, getEpochIndex, getSlotIndex, headerHash, mkCoin, @@ -203,10 +203,8 @@ data CBlockEntry = CBlockEntry instance NFData CBlockEntry toBlockEntry - :: ExplorerMode ctx m - => (MainBlock, Undo) - -> m CBlockEntry -toBlockEntry (blk, Undo{..}) = do + :: ExplorerMode ctx m => SlotCount -> (MainBlock, Undo) -> m CBlockEntry +toBlockEntry epochSlots (blk, Undo{..}) = do blkSlotStart <- getSlotStartCSLI $ blk ^. gbHeader . gbhConsensus . mcdSlot @@ -216,7 +214,7 @@ toBlockEntry (blk, Undo{..}) = do slotIndex = siSlot blkHeaderSlot -- Find the epoch and slot leader - epochSlotLeader <- Lrc.getLeader $ SlotId epochIndex slotIndex + epochSlotLeader <- Lrc.getLeader epochSlots $ SlotId epochIndex slotIndex -- Fill required fields for @CBlockEntry@ let cbeEpoch = getEpochIndex epochIndex @@ -270,17 +268,16 @@ data CBlockSummary = CBlockSummary } deriving (Show, Generic) toBlockSummary - :: ExplorerMode ctx m - => (MainBlock, Undo) - -> m CBlockSummary -toBlockSummary blund@(blk, _) = do - cbsEntry <- toBlockEntry blund + :: ExplorerMode ctx m => SlotCount -> (MainBlock, Undo) -> m CBlockSummary +toBlockSummary epochSlots blund@(blk, _) = do + cbsEntry <- toBlockEntry epochSlots blund cbsNextHash <- fmap toCHash <$> GS.resolveForwardLink blk - let blockTxs = blk ^. mainBlockTxPayload . txpTxs + let blockTxs = blk ^. mainBlockTxPayload . txpTxs - let cbsPrevHash = toCHash $ blk ^. prevBlockL - let cbsMerkleRoot = toCHash . getMerkleRoot . mtRoot . mkMerkleTree $ blockTxs + let cbsPrevHash = toCHash $ blk ^. prevBlockL + let cbsMerkleRoot = + toCHash . getMerkleRoot . mtRoot . mkMerkleTree $ blockTxs return CBlockSummary {..} diff --git a/explorer/src/Pos/Explorer/Web/Server.hs b/explorer/src/Pos/Explorer/Web/Server.hs index 3ff06ed6615..fe18df54845 100644 --- a/explorer/src/Pos/Explorer/Web/Server.hs +++ b/explorer/src/Pos/Explorer/Web/Server.hs @@ -57,8 +57,8 @@ import Pos.Infra.Diffusion.Types (Diffusion) import Pos.Binary.Class (biSize) import Pos.Block.Types (Blund, Undo) import Pos.Core (AddrType (..), Address (..), Coin, EpochIndex, - HeaderHash, Timestamp, coinToInteger, difficultyL, - gbHeader, gbhConsensus, getChainDifficulty, + HeaderHash, SlotCount, Timestamp, coinToInteger, + difficultyL, gbHeader, gbhConsensus, getChainDifficulty, isUnknownAddressType, makeRedeemAddress, siEpoch, siSlot, sumCoins, timestampToPosix, unsafeAddCoin, unsafeIntegerToCoin, unsafeSubCoin) @@ -120,24 +120,27 @@ explorerApp serv = serve explorerApi <$> serv ---------------------------------------------------------------- explorerHandlers - :: forall ctx m. ExplorerMode ctx m - => Diffusion m -> ServerT ExplorerApi m -explorerHandlers _diffusion = + :: forall ctx m + . ExplorerMode ctx m + => SlotCount + -> Diffusion m + -> ServerT ExplorerApi m +explorerHandlers epochSlots _diffusion = toServant (ExplorerApiRecord { _totalAda = getTotalAda - , _blocksPages = getBlocksPage + , _blocksPages = getBlocksPage epochSlots , _blocksPagesTotal = getBlocksPagesTotal - , _blocksSummary = getBlockSummary + , _blocksSummary = getBlockSummary epochSlots , _blocksTxs = getBlockTxs , _txsLast = getLastTxs , _txsSummary = getTxSummary , _addressSummary = getAddressSummary - , _epochPages = getEpochPage - , _epochSlots = getEpochSlot + , _epochPages = getEpochPage epochSlots + , _epochSlots = getEpochSlot epochSlots , _genesisSummary = getGenesisSummary , _genesisPagesTotal = getGenesisPagesTotal , _genesisAddressInfo = getGenesisAddressInfo - , _statsTxs = getStatsTxs + , _statsTxs = getStatsTxs epochSlots } :: ExplorerApiRecord (AsServerT m)) @@ -176,10 +179,11 @@ getBlocksTotal = do -- Currently the pages are in chronological order. getBlocksPage :: ExplorerMode ctx m - => Maybe Word -- ^ Page number + => SlotCount + -> Maybe Word -- ^ Page number -> Maybe Word -- ^ Page size -> m (Integer, [CBlockEntry]) -getBlocksPage mPageNumber mPageSize = do +getBlocksPage epochSlots mPageNumber mPageSize = do let pageSize = toPageSize mPageSize @@ -207,7 +211,7 @@ getBlocksPage mPageNumber mPageSize = do -- TODO: Fix this Int / Integer thing once we merge repositories pageBlocksHH <- getPageHHsOrThrow $ fromIntegral pageNumber blunds <- forM pageBlocksHH getBlundOrThrow - cBlocksEntry <- forM (blundToMainBlockUndo blunds) toBlockEntry + cBlocksEntry <- forM (blundToMainBlockUndo blunds) (toBlockEntry epochSlots) -- Return total pages and the blocks. We start from page 1. pure (totalPages, reverse cBlocksEntry) @@ -257,9 +261,9 @@ getBlocksPagesTotal mPageSize = do -- | Get the last page from the blockchain. We use the default 10 -- for the page size since this is called from __explorer only__. getBlocksLastPage - :: ExplorerMode ctx m - => m (Integer, [CBlockEntry]) -getBlocksLastPage = getBlocksPage Nothing (Just defaultPageSizeWord) + :: ExplorerMode ctx m => SlotCount -> m (Integer, [CBlockEntry]) +getBlocksLastPage epochSlots = + getBlocksPage epochSlots Nothing (Just defaultPageSizeWord) -- | Get last transactions from the blockchain. @@ -298,14 +302,11 @@ getLastTxs = do -- | Get block summary. -getBlockSummary - :: ExplorerMode ctx m - => CHash - -> m CBlockSummary -getBlockSummary cHash = do +getBlockSummary :: ExplorerMode ctx m => SlotCount -> CHash -> m CBlockSummary +getBlockSummary epochSlots cHash = do headerHash <- unwrapOrThrow $ fromCHash cHash mainBlund <- getMainBlund headerHash - toBlockSummary mainBlund + toBlockSummary epochSlots mainBlund -- | Get transactions from a block. @@ -601,10 +602,11 @@ getGenesisPagesTotal mPageSize addrFilt = do -- | Search the blocks by epoch and slot. getEpochSlot :: ExplorerMode ctx m - => EpochIndex + => SlotCount + -> EpochIndex -> Word16 -> m [CBlockEntry] -getEpochSlot epochIndex slotIndex = do +getEpochSlot epochSlots epochIndex slotIndex = do -- The slots start from 0 so we need to modify the calculation of the index. let page = fromIntegral $ (slotIndex `div` 10) + 1 @@ -613,7 +615,7 @@ getEpochSlot epochIndex slotIndex = do -- TODO: Fix this Int / Integer thing once we merge repositories epochBlocksHH <- getPageHHsOrThrow epochIndex page blunds <- forM epochBlocksHH getBlundOrThrow - forM (getEpochSlots slotIndex (blundToMainBlockUndo blunds)) toBlockEntry + forM (getEpochSlots slotIndex (blundToMainBlockUndo blunds)) (toBlockEntry epochSlots) where blundToMainBlockUndo :: [Blund] -> [(MainBlock, Undo)] blundToMainBlockUndo blund = [(mainBlock, undo) | (Right mainBlock, undo) <- blund] @@ -650,10 +652,11 @@ getEpochSlot epochIndex slotIndex = do -- | Search the blocks by epoch and epoch page number. getEpochPage :: ExplorerMode ctx m - => EpochIndex + => SlotCount + -> EpochIndex -> Maybe Int -> m (Int, [CBlockEntry]) -getEpochPage epochIndex mPage = do +getEpochPage epochSlots epochIndex mPage = do -- Get the page if it exists, return first page otherwise. let page = fromMaybe 1 mPage @@ -669,7 +672,7 @@ getEpochPage epochIndex mPage = do let sortedBlunds = sortBlocksByEpochSlots blunds let sortedMainBlocks = blundToMainBlockUndo sortedBlunds - cBlocksEntry <- forM sortedMainBlocks toBlockEntry + cBlocksEntry <- forM sortedMainBlocks (toBlockEntry epochSlots) pure (epochPagesNumber, cBlocksEntry) where @@ -703,12 +706,14 @@ getEpochPage epochIndex mPage = do fromIntegral $ (+1) $ getSlotIndex $ siSlot $ block ^. mainBlockSlot getStatsTxs - :: forall ctx m. ExplorerMode ctx m - => Maybe Word + :: forall ctx m + . ExplorerMode ctx m + => SlotCount + -> Maybe Word -> m (Integer, [(CTxId, Byte)]) -getStatsTxs mPageNumber = do +getStatsTxs epochSlots mPageNumber = do -- Get blocks from the requested page - blocksPage <- getBlocksPage mPageNumber (Just defaultPageSizeWord) + blocksPage <- getBlocksPage epochSlots mPageNumber (Just defaultPageSizeWord) getBlockPageTxsInfo blocksPage where getBlockPageTxsInfo diff --git a/explorer/src/Pos/Explorer/Web/Transform.hs b/explorer/src/Pos/Explorer/Web/Transform.hs index cb944f2191e..4245e8c22c4 100644 --- a/explorer/src/Pos/Explorer/Web/Transform.hs +++ b/explorer/src/Pos/Explorer/Web/Transform.hs @@ -24,7 +24,7 @@ import Servant.Server (Handler, hoistServer) import Pos.Block.Configuration (HasBlockConfiguration) import Pos.Configuration (HasNodeConfiguration) -import Pos.Core (HasConfiguration) +import Pos.Core (HasConfiguration, SlotCount) import Pos.Infra.Diffusion.Types (Diffusion) import Pos.Infra.Reporting (MonadReporting (..)) import Pos.Recovery () @@ -62,8 +62,8 @@ instance (HasConfiguration, HasTxpConfiguration) => instance (HasConfiguration, HasTxpConfiguration) => MonadTxpLocal ExplorerProd where - txpNormalize = lift . lift . txpNormalize - txpProcessTx pm = lift . lift . txpProcessTx pm + txpNormalize pm = lift . lift . txpNormalize pm + txpProcessTx pm epochSlots = lift . lift . txpProcessTx pm epochSlots -- | Use the 'RealMode' instance. -- FIXME instance on a type synonym. @@ -87,26 +87,29 @@ type HasExplorerConfiguration = notifierPlugin :: HasExplorerConfiguration - => NotifierSettings + => SlotCount + -> NotifierSettings -> Diffusion ExplorerProd -> ExplorerProd () -notifierPlugin settings _ = notifierApp settings +notifierPlugin epochSlots settings _ = notifierApp epochSlots settings explorerPlugin :: HasExplorerConfiguration - => Word16 + => SlotCount + -> Word16 -> Diffusion ExplorerProd -> ExplorerProd () -explorerPlugin = flip explorerServeWebReal +explorerPlugin epochSlots = flip $ explorerServeWebReal epochSlots explorerServeWebReal :: HasExplorerConfiguration - => Diffusion ExplorerProd + => SlotCount + -> Diffusion ExplorerProd -> Word16 -> ExplorerProd () -explorerServeWebReal diffusion port = do +explorerServeWebReal epochSlots diffusion port = do rctx <- ask - let handlers = explorerHandlers diffusion + let handlers = explorerHandlers epochSlots diffusion server = hoistServer explorerApi (convertHandler rctx) handlers app = explorerApp (pure server) explorerServeImpl app port diff --git a/explorer/src/explorer/Main.hs b/explorer/src/explorer/Main.hs index 3fb5675d695..a3a3b29668d 100644 --- a/explorer/src/explorer/Main.hs +++ b/explorer/src/explorer/Main.hs @@ -22,7 +22,7 @@ import Pos.Client.CLI (CommonNodeArgs (..), NodeArgs (..), getNodeParams) import qualified Pos.Client.CLI as CLI import Pos.Context (NodeContext (..)) -import Pos.Core (epochSlots) +import Pos.Core (ProtocolConstants, pcBlkSecurityParam, pcEpochSlots) import Pos.Crypto (ProtocolMagic) import Pos.Explorer.DB (explorerInitDB) import Pos.Explorer.ExtraContext (makeExtraCtx) @@ -57,26 +57,39 @@ main = do action args action :: ExplorerNodeArgs -> Production () -action (ExplorerNodeArgs (cArgs@CommonNodeArgs{..}) ExplorerArgs{..}) = - withConfigurations blPath conf $ \ntpConfig pm -> - withCompileInfo $ do - CLI.printInfoOnStart cArgs ntpConfig - logInfo $ "Explorer is enabled!" - currentParams <- getNodeParams loggerName cArgs nodeArgs +action (ExplorerNodeArgs (cArgs@CommonNodeArgs {..}) ExplorerArgs {..}) = + withConfigurations blPath conf $ \ntpConfig pm pc -> + withCompileInfo $ do + CLI.printInfoOnStart cArgs ntpConfig + logInfo $ "Explorer is enabled!" + currentParams <- getNodeParams loggerName cArgs nodeArgs - let vssSK = fromJust $ npUserSecret currentParams ^. usVss - let sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig currentParams) + let vssSK = fromJust $ npUserSecret currentParams ^. usVss + let sscParams = CLI.gtSscParams + cArgs + vssSK + (npBehaviorConfig currentParams) + let epochSlots = pcEpochSlots pc - let plugins :: [Diffusion ExplorerProd -> ExplorerProd ()] - plugins = - [ explorerPlugin webPort - , notifierPlugin NotifierSettings{ nsPort = notifierPort } - , updateTriggerWorker - ] - bracketNodeResources currentParams sscParams - (explorerTxpGlobalSettings pm) - (explorerInitDB pm epochSlots) $ \nr@NodeResources {..} -> - Production (runExplorerRealMode pm nr (runNode pm nr plugins)) + let + plugins :: [Diffusion ExplorerProd -> ExplorerProd ()] + plugins = + [ explorerPlugin epochSlots webPort + , notifierPlugin + epochSlots + NotifierSettings {nsPort = notifierPort} + , updateTriggerWorker + ] + bracketNodeResources (pcBlkSecurityParam pc) + currentParams + sscParams + (explorerTxpGlobalSettings pm) + (explorerInitDB pm pc) + $ \nr@NodeResources {..} -> Production $ runExplorerRealMode + pm + pc + nr + (runNode pm pc nr plugins) where blPath :: Maybe AssetLockPath @@ -86,17 +99,21 @@ action (ExplorerNodeArgs (cArgs@CommonNodeArgs{..}) ExplorerArgs{..}) = conf = CLI.configurationOptions $ CLI.commonArgs cArgs runExplorerRealMode - :: (HasConfigurations,HasCompileInfo) + :: (HasConfigurations, HasCompileInfo) => ProtocolMagic + -> ProtocolConstants -> NodeResources ExplorerExtraModifier -> (Diffusion ExplorerProd -> ExplorerProd ()) -> IO () - runExplorerRealMode pm nr@NodeResources{..} go = - let NodeContext {..} = nrContext - extraCtx = makeExtraCtx - explorerModeToRealMode = runExplorerProd extraCtx - in runRealMode pm nr $ \diffusion -> - explorerModeToRealMode (go (hoistDiffusion (lift . lift) explorerModeToRealMode diffusion)) + runExplorerRealMode pm pc nr@NodeResources {..} go = + let NodeContext {..} = nrContext + extraCtx = makeExtraCtx + explorerModeToRealMode = runExplorerProd extraCtx + in runRealMode pm pc nr $ \diffusion -> + explorerModeToRealMode $ go $ hoistDiffusion + (lift . lift) + explorerModeToRealMode + diffusion nodeArgs :: NodeArgs - nodeArgs = NodeArgs { behaviorConfigPath = Nothing } + nodeArgs = NodeArgs {behaviorConfigPath = Nothing} diff --git a/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs b/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs index 317aba5423f..36cc5a62c22 100644 --- a/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs +++ b/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs @@ -32,6 +32,7 @@ import Pos.Util.Mockable () import Test.Pos.Block.Arbitrary () import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Core.Dummy (dummyEpochSlots) ---------------------------------------------------------------- @@ -42,7 +43,7 @@ import Test.Pos.Configuration (withDefConfigurations) -- stack test cardano-sl-explorer --fast --test-arguments "-m Pos.Explorer.Web.Server" spec :: Spec -spec = withDefConfigurations $ \_ _ -> do +spec = withDefConfigurations $ \_ -> do describe "Pos.Explorer.Web.Server" $ do blocksTotalSpec blocksPagesTotalSpec @@ -192,7 +193,7 @@ blocksPageUnitSpec = let blockExecution :: IO (Integer, [CBlockEntry]) blockExecution = runExplorerTestMode testParams extraContext - $ getBlocksPage Nothing (Just 10) + $ getBlocksPage dummyEpochSlots Nothing (Just 10) -- We finally run it as @PropertyM@ and check if it holds. pagesTotal <- fst <$> run blockExecution @@ -234,7 +235,7 @@ blocksLastPageUnitSpec = -- a million instances. let blocksLastPageM :: IO (Integer, [CBlockEntry]) blocksLastPageM = - runExplorerTestMode testParams extraContext getBlocksLastPage + runExplorerTestMode testParams extraContext (getBlocksLastPage dummyEpochSlots) -- We run the function in @BlockTestMode@ so we don't need to define -- a million instances. @@ -242,7 +243,7 @@ blocksLastPageUnitSpec = let blocksPageM :: IO (Integer, [CBlockEntry]) blocksPageM = runExplorerTestMode testParams extraContext - $ getBlocksPage Nothing (Just 10) + $ getBlocksPage dummyEpochSlots Nothing (Just 10) -- We finally run it as @PropertyM@ and check if it holds. blocksLastPage <- run blocksLastPageM @@ -278,6 +279,7 @@ epochSlotUnitSpec = do epochSlotM = runExplorerTestMode testParams extraContext $ getEpochSlot + dummyEpochSlots (EpochIndex 0) 1 @@ -315,6 +317,7 @@ epochPageUnitSpec = do epochPageM = runExplorerTestMode testParams extraContext $ getEpochPage + dummyEpochSlots (EpochIndex 0) Nothing diff --git a/generator/cardano-sl-generator.cabal b/generator/cardano-sl-generator.cabal index f34a6524f89..92895cdee64 100644 --- a/generator/cardano-sl-generator.cabal +++ b/generator/cardano-sl-generator.cabal @@ -41,6 +41,7 @@ library , cardano-sl-block , cardano-sl-client , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto , cardano-sl-crypto-test , cardano-sl-db @@ -129,6 +130,7 @@ test-suite cardano-generator-test , cardano-sl-block , cardano-sl-block-test , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto , cardano-sl-crypto-test , cardano-sl-db diff --git a/generator/src/Pos/Generator/Block/Logic.hs b/generator/src/Pos/Generator/Block/Logic.hs index 7deccafc984..f2a32c75686 100644 --- a/generator/src/Pos/Generator/Block/Logic.hs +++ b/generator/src/Pos/Generator/Block/Logic.hs @@ -24,8 +24,11 @@ import Pos.Block.Lrc (lrcSingleShot) import Pos.Block.Slog (ShouldCallBListener (..)) import Pos.Block.Types (Blund) import Pos.Communication.Message () -import Pos.Core (EpochOrSlot (..), SlotId (..), addressHash, - epochIndexL, getEpochOrSlot, getSlotIndex) +import Pos.Core (EpochOrSlot (..), ProtocolConstants, SlotId (..), + addressHash, epochIndexL, epochOrSlotEnumFromTo, + epochOrSlotFromEnum, epochOrSlotSucc, epochOrSlotToEnum, + getEpochOrSlot, getSlotIndex, localSlotIndexMinBound, + pcBlkSecurityParam, pcEpochSlots) import Pos.Core.Block (Block) import Pos.Core.Block.Constructors (mkGenesisBlock) import Pos.Crypto (ProtocolMagic, pskDelegatePk) @@ -67,26 +70,33 @@ type BlockTxpGenMode g ctx m = genBlocks :: forall g ctx m t . (HasTxpConfiguration, BlockTxpGenMode g ctx m, Semigroup t, Monoid t) => ProtocolMagic + -> ProtocolConstants -> BlockGenParams -> (Maybe Blund -> t) -> RandT g m t -genBlocks pm params inj = do - ctx <- lift $ mkBlockGenContext @(MempoolExt m) params +genBlocks pm pc params inj = do + ctx <- lift $ mkBlockGenContext @(MempoolExt m) epochSlots params mapRandT (`runReaderT` ctx) genBlocksDo where + epochSlots = pcEpochSlots pc genBlocksDo = do let numberOfBlocks = params ^. bgpBlockCount tipEOS <- getEpochOrSlot <$> lift DB.getTipHeader - let startEOS = succ tipEOS - let finishEOS = toEnum $ fromEnum tipEOS + fromIntegral numberOfBlocks - foldM' genOneBlock mempty [startEOS .. finishEOS] + let startEOS = epochOrSlotSucc epochSlots tipEOS + let finishEOS = + epochOrSlotToEnum epochSlots + $ epochOrSlotFromEnum epochSlots tipEOS + + fromIntegral numberOfBlocks + foldM' genOneBlock + mempty + (epochOrSlotEnumFromTo epochSlots startEOS finishEOS) - genOneBlock t eos = ((t <>) . inj) <$> genBlock pm eos + genOneBlock t eos = ((t <>) . inj) <$> genBlock pm pc eos foldM' combine = go where - go !base [] = return base - go !base (x:xs) = combine base x >>= flip go xs + go !base [] = return base + go !base (x : xs) = combine base x >>= flip go xs -- Generate a valid 'Block' for the given epoch or slot (genesis block -- in the former case and main block the latter case) and apply it. @@ -99,60 +109,67 @@ genBlock , HasTxpConfiguration ) => ProtocolMagic + -> ProtocolConstants -> EpochOrSlot -> BlockGenRandMode (MempoolExt m) g m (Maybe Blund) -genBlock pm eos = do +genBlock pm pc eos = do let epoch = eos ^. epochIndexL - lift $ unlessM ((epoch ==) <$> LrcDB.getEpoch) (lrcSingleShot pm epoch) + lift $ unlessM ((epoch ==) <$> LrcDB.getEpoch) (lrcSingleShot pm pc epoch) -- We need to know leaders to create any block. - leaders <- lift $ lrcActionOnEpochReason epoch "genBlock" LrcDB.getLeadersForEpoch + leaders <- lift + $ lrcActionOnEpochReason epoch "genBlock" LrcDB.getLeadersForEpoch case eos of EpochOrSlot (Left _) -> do tipHeader <- lift DB.getTipHeader - let slot0 = SlotId epoch minBound - let genesisBlock = mkGenesisBlock pm (Right tipHeader) epoch leaders - fmap Just $ withCurrentSlot slot0 $ lift $ verifyAndApply (Left genesisBlock) + let slot0 = SlotId epoch localSlotIndexMinBound + let genesisBlock = + mkGenesisBlock pm (Right tipHeader) epoch leaders + fmap Just $ withCurrentSlot slot0 $ lift $ verifyAndApply + (Left genesisBlock) EpochOrSlot (Right slot@SlotId {..}) -> withCurrentSlot slot $ do - genPayload pm slot - leader <- - lift $ maybeThrow - (BGInternal "no leader") - (leaders ^? ix (fromIntegral $ getSlotIndex siSlot)) + genPayload pm (pcEpochSlots pc) slot + leader <- lift $ maybeThrow + (BGInternal "no leader") + (leaders ^? ix (fromIntegral $ getSlotIndex siSlot)) secrets <- unInvSecretsMap . view asSecretKeys <$> view blockGenParams transCert <- lift $ getDlgTransPsk leader - let creator = maybe leader (addressHash . pskDelegatePk . snd) transCert + let creator = + maybe leader (addressHash . pskDelegatePk . snd) transCert let maybeLeader = secrets ^. at creator canSkip <- view bgpSkipNoKey case (maybeLeader, canSkip) of - (Nothing,True) -> do - lift $ logWarning $ - sformat ("Skipping block creation for leader "%build% - " as no related key was found") - leader + (Nothing, True) -> do + lift $ logWarning $ sformat + ( "Skipping block creation for leader " + % build + % " as no related key was found" + ) + leader pure Nothing - (Nothing,False) -> - throwM $ BGUnknownSecret leader - (Just leaderSK, _) -> - -- When we know the secret key we can proceed to the actual creation. - Just <$> usingPrimaryKey leaderSK - (lift $ genMainBlock slot (swap <$> transCert)) + (Nothing , False) -> throwM $ BGUnknownSecret leader + -- When we know the secret key we can proceed to the actual creation. + (Just leaderSK, _ ) -> Just <$> usingPrimaryKey + leaderSK + (lift $ genMainBlock slot (swap <$> transCert)) where - genMainBlock :: - SlotId -> - ProxySKBlockInfo -> - BlockGenMode (MempoolExt m) m Blund + genMainBlock + :: SlotId -> ProxySKBlockInfo -> BlockGenMode (MempoolExt m) m Blund genMainBlock slot proxySkInfo = - createMainBlockInternal pm slot proxySkInfo >>= \case - Left err -> throwM (BGFailedToCreate err) - Right mainBlock -> verifyAndApply $ Right mainBlock + createMainBlockInternal pm (pcBlkSecurityParam pc) slot proxySkInfo + >>= \case + Left err -> throwM (BGFailedToCreate err) + Right mainBlock -> verifyAndApply $ Right mainBlock verifyAndApply :: Block -> BlockGenMode (MempoolExt m) m Blund - verifyAndApply block = - verifyBlocksPrefix pm (one block) >>= \case - Left err -> throwM (BGCreatedInvalid err) - Right (undos, pollModifier) -> do - let undo = undos ^. _Wrapped . _neHead - blund = (block, undo) - applyBlocksUnsafe pm (ShouldCallBListener True) (one blund) (Just pollModifier) - normalizeMempool pm - pure blund + verifyAndApply block = verifyBlocksPrefix pm pc (one block) >>= \case + Left err -> throwM (BGCreatedInvalid err) + Right (undos, pollModifier) -> do + let undo = undos ^. _Wrapped . _neHead + blund = (block, undo) + applyBlocksUnsafe pm + pc + (ShouldCallBListener True) + (one blund) + (Just pollModifier) + normalizeMempool pm pc + pure blund diff --git a/generator/src/Pos/Generator/Block/Mode.hs b/generator/src/Pos/Generator/Block/Mode.hs index c03f83b8388..f896fb75c75 100644 --- a/generator/src/Pos/Generator/Block/Mode.hs +++ b/generator/src/Pos/Generator/Block/Mode.hs @@ -37,7 +37,7 @@ import Pos.Block.Slog (HasSlogGState (..)) import Pos.Client.Txp.Addresses (MonadAddresses (..)) import Pos.Configuration (HasNodeConfiguration) import Pos.Core (Address, GenesisWStakeholders (..), HasConfiguration, - HasPrimaryKey (..), SlotId (..), Timestamp, + HasPrimaryKey (..), SlotCount, SlotId (..), Timestamp, epochOrSlotToSlot, getEpochOrSlot, largestPubKeyAddressBoot) import Pos.Crypto (SecretKey) @@ -156,13 +156,12 @@ instance MonadThrow m => MonadThrow (RandT g m) where -- context. Persistent data (DB) is cloned. Other mutable data is -- recreated. mkBlockGenContext - :: forall ext ctx m. - ( MonadBlockGenInit ctx m - , Default ext - ) - => BlockGenParams + :: forall ext ctx m + . (MonadBlockGenInit ctx m, Default ext) + => SlotCount + -> BlockGenParams -> m (BlockGenContext ext) -mkBlockGenContext bgcParams@BlockGenParams{..} = do +mkBlockGenContext epochSlots bgcParams@BlockGenParams{..} = do let bgcPrimaryKey = error "bgcPrimaryKey was forced before being set" bgcGState <- if _bgpInplaceDB then view GS.gStateContext @@ -182,8 +181,8 @@ mkBlockGenContext bgcParams@BlockGenParams{..} = do usingReaderT initCtx $ do tipEOS <- getEpochOrSlot <$> DB.getTipHeader putInitSlot (epochOrSlotToSlot tipEOS) - bgcSscState <- mkSscState - bgcUpdateContext <- mkUpdateContext + bgcSscState <- mkSscState epochSlots + bgcUpdateContext <- mkUpdateContext epochSlots bgcTxpMem <- mkTxpLocalData bgcDelegation <- mkDelegationVar return BlockGenContext {..} @@ -227,10 +226,10 @@ instance MonadBlockGenBase m => MonadDB (InitBlockGenMode ext m) where instance (MonadBlockGenBase m, MonadSlotsData ctx (InitBlockGenMode ext m)) => MonadSlots ctx (InitBlockGenMode ext m) where - getCurrentSlot = Just <$> view ibgcSlot_L - getCurrentSlotBlocking = view ibgcSlot_L - getCurrentSlotInaccurate = view ibgcSlot_L - currentTimeSlotting = do + getCurrentSlot _ = Just <$> view ibgcSlot_L + getCurrentSlotBlocking _ = view ibgcSlot_L + getCurrentSlotInaccurate _ = view ibgcSlot_L + currentTimeSlotting = do logWarning "currentTimeSlotting is used in initialization" currentTimeSlottingSimple @@ -317,14 +316,14 @@ instance MonadBlockGenBase m => MonadDB (BlockGenMode ext m) where instance (MonadBlockGenBase m, MonadSlotsData ctx (BlockGenMode ext m)) => MonadSlots ctx (BlockGenMode ext m) where - getCurrentSlot = view bgcSlotId_L - getCurrentSlotBlocking = + getCurrentSlot _ = view bgcSlotId_L + getCurrentSlotBlocking _ = view bgcSlotId_L >>= \case Nothing -> reportFatalError "getCurrentSlotBlocking is used in generator when slot is unknown" Just slot -> pure slot - getCurrentSlotInaccurate = + getCurrentSlotInaccurate _ = reportFatalError "It hardly makes sense to use 'getCurrentSlotInaccurate' during block generation" currentTimeSlotting = currentTimeSlottingSimple @@ -334,18 +333,18 @@ instance MonadBlockGenBase m => DB.MonadGState (BlockGenMode ext m) where instance MonadBListener m => MonadBListener (BlockGenMode ext m) where onApplyBlocks = lift . onApplyBlocks - onRollbackBlocks = lift . onRollbackBlocks + onRollbackBlocks pc = lift . onRollbackBlocks pc instance Monad m => MonadAddresses (BlockGenMode ext m) where type AddrData (BlockGenMode ext m) = Address - getNewAddress = pure + getNewAddress _ = pure -- It must be consistent with the way we construct address in -- block-gen. If it's changed, tests will fail, so we will notice -- it. -- N.B. Currently block-gen uses only PubKey addresses with BootstrapEra -- distribution. - getFakeChangeAddress = pure largestPubKeyAddressBoot + getFakeChangeAddress _ = pure largestPubKeyAddressBoot type instance MempoolExt (BlockGenMode ext m) = ext diff --git a/generator/src/Pos/Generator/Block/Payload.hs b/generator/src/Pos/Generator/Block/Payload.hs index 010b447a007..309f12dc926 100644 --- a/generator/src/Pos/Generator/Block/Payload.hs +++ b/generator/src/Pos/Generator/Block/Payload.hs @@ -25,7 +25,7 @@ import Pos.AllSecrets (asSecretKeys, asSpendingData, unInvAddrSpendingData, unInvSecretsMap) import Pos.Client.Txp.Util (InputSelectionPolicy (..), TxError (..), createGenericTx, makeMPubKeyTxAddrs) -import Pos.Core (AddrSpendingData (..), Address (..), Coin, +import Pos.Core (AddrSpendingData (..), Address (..), Coin, SlotCount, SlotId (..), addressHash, coinToInteger, makePubKeyAddressBoot, unsafeIntegerToCoin) import Pos.Core.Txp (Tx (..), TxAux (..), TxIn (..), TxOut (..), @@ -121,8 +121,9 @@ genTxPayload :: forall ext g m . (RandomGen g, MonadBlockGenBase m, MonadTxpLocal (BlockGenMode ext m)) => ProtocolMagic + -> SlotCount -> BlockGenRandMode ext g m () -genTxPayload pm = do +genTxPayload pm epochSlots = do invAddrSpendingData <- unInvAddrSpendingData <$> view (blockGenParams . asSpendingData) -- We only leave outputs we have secret keys related to. Tx @@ -215,14 +216,14 @@ genTxPayload pm = do groupedInputs = OptimizeForSecurity eTx <- lift . lift $ - createGenericTx pm mempty makeTestTx groupedInputs ownUtxo txOutAuxs changeAddrData + createGenericTx pm epochSlots mempty makeTestTx groupedInputs ownUtxo txOutAuxs changeAddrData (txAux, _) <- either (throwM . BGFailedToCreate . pretty) pure eTx let tx = taTx txAux let txId = hash tx let txIns = _txInputs tx -- @txpProcessTx@ for BlockGenMode should be non-blocking - res <- lift . lift $ txpProcessTx pm (txId, txAux) + res <- lift . lift $ txpProcessTx pm epochSlots (txId, txAux) case res of Left e -> error $ "genTransaction@txProcessTransaction: got left: " <> pretty e Right _ -> do @@ -247,6 +248,7 @@ genPayload :: forall ext g m . (RandomGen g, MonadBlockGenBase m, MonadTxpLocal (BlockGenMode ext m)) => ProtocolMagic + -> SlotCount -> SlotId -> BlockGenRandMode ext g m () -genPayload pm _ = genTxPayload pm +genPayload pm epochSlots _ = genTxPayload pm epochSlots diff --git a/generator/src/Pos/Generator/BlockEvent.hs b/generator/src/Pos/Generator/BlockEvent.hs index 3b82df0ba77..88cb50e6f42 100644 --- a/generator/src/Pos/Generator/BlockEvent.hs +++ b/generator/src/Pos/Generator/BlockEvent.hs @@ -61,8 +61,8 @@ import Serokell.Util (listJson) import Pos.AllSecrets (AllSecrets) import Pos.Block.Types (Blund) -import Pos.Core (GenesisWStakeholders, HeaderHash, headerHash, - prevBlockL) +import Pos.Core (GenesisWStakeholders, HeaderHash, ProtocolConstants, + headerHash, prevBlockL) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst, toOldestFirst, _OldestFirst) import Pos.Crypto (ProtocolMagic) @@ -159,22 +159,24 @@ flattenBlockchainTree prePath tree = do genBlocksInForest :: (HasTxpConfiguration, BlockTxpGenMode g ctx m) => ProtocolMagic + -> ProtocolConstants -> AllSecrets -> GenesisWStakeholders -> BlockchainForest BlockDesc -> RandT g m (BlockchainForest Blund) -genBlocksInForest pm secrets bootStakeholders = +genBlocksInForest pm pc secrets bootStakeholders = traverse $ mapRandT withClonedGState . - genBlocksInTree pm secrets bootStakeholders + genBlocksInTree pm pc secrets bootStakeholders genBlocksInTree :: (HasTxpConfiguration, BlockTxpGenMode g ctx m) => ProtocolMagic + -> ProtocolConstants -> AllSecrets -> GenesisWStakeholders -> BlockchainTree BlockDesc -> RandT g m (BlockchainTree Blund) -genBlocksInTree pm secrets bootStakeholders blockchainTree = do +genBlocksInTree pm pc secrets bootStakeholders blockchainTree = do txpSettings <- view (lensOf' @TxpGlobalSettings) let BlockchainTree blockDesc blockchainForest = blockchainTree txGenParams = case blockDesc of @@ -189,14 +191,15 @@ genBlocksInTree pm secrets bootStakeholders blockchainTree = do , _bgpSkipNoKey = False , _bgpTxpGlobalSettings = txpSettings } - blocks <- genBlocks pm blockGenParams maybeToList + blocks <- genBlocks pm pc blockGenParams maybeToList block <- case blocks of [block] -> return block _ -> -- We specify '_bgpBlockCount = 1' above, so the output must contain -- exactly one block. error "genBlocksInTree: impossible - 'genBlocks' generated unexpected amount of blocks" - forestBlocks <- genBlocksInForest pm secrets bootStakeholders blockchainForest + forestBlocks <- + genBlocksInForest pm pc secrets bootStakeholders blockchainForest return $ BlockchainTree block forestBlocks -- Precondition: paths in the structure are non-empty. @@ -205,12 +208,13 @@ genBlocksInStructure :: , BlockTxpGenMode g ctx m , Functor t, Foldable t) => ProtocolMagic + -> ProtocolConstants -> AllSecrets -> GenesisWStakeholders -> Map Path BlockDesc -> t Path -> RandT g m (t Blund) -genBlocksInStructure pm secrets bootStakeholders annotations s = do +genBlocksInStructure pm pc secrets bootStakeholders annotations s = do let getAnnotation :: Path -> BlockDesc getAnnotation path = @@ -220,7 +224,7 @@ genBlocksInStructure pm secrets bootStakeholders annotations s = do descForest :: BlockchainForest BlockDesc descForest = buildBlockchainForest BlockDescDefault paths blockForest :: BlockchainForest Blund <- - genBlocksInForest pm secrets bootStakeholders descForest + genBlocksInForest pm pc secrets bootStakeholders descForest let getBlock :: Path -> Blund getBlock path = Map.findWithDefault diff --git a/generator/src/Pos/Generator/BlockEvent/DSL.hs b/generator/src/Pos/Generator/BlockEvent/DSL.hs index d9c9bd0f344..45bcd4efb68 100644 --- a/generator/src/Pos/Generator/BlockEvent/DSL.hs +++ b/generator/src/Pos/Generator/BlockEvent/DSL.hs @@ -34,7 +34,7 @@ import Control.Monad.Random.Strict (RandT, mapRandT) import qualified Data.Map as Map import Pos.AllSecrets (AllSecrets) -import Pos.Core (GenesisWStakeholders) +import Pos.Core (GenesisWStakeholders, ProtocolConstants) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toOldestFirst, _NewestFirst) import Pos.Crypto (ProtocolMagic) @@ -118,13 +118,19 @@ snapshotEq snapshotId = emitEvent $ runBlockEventGenT :: (HasTxpConfiguration, BlockTxpGenMode g ctx m) => ProtocolMagic + -> ProtocolConstants -> AllSecrets -> GenesisWStakeholders -> BlockEventGenT g m () -> RandT g m BlockScenario -runBlockEventGenT pm secrets genStakeholders m = do +runBlockEventGenT pm pc secrets genStakeholders m = do (annotations, preBlockScenario) <- runBlockEventGenT' m - genBlocksInStructure pm secrets genStakeholders annotations preBlockScenario + genBlocksInStructure pm + pc + secrets + genStakeholders + annotations + preBlockScenario runBlockEventGenT' :: (MonadBlockGen ctx m) => diff --git a/generator/src/Test/Pos/Block/Logic/Event.hs b/generator/src/Test/Pos/Block/Logic/Event.hs index 28f74ccc70d..11fde4d5146 100644 --- a/generator/src/Test/Pos/Block/Logic/Event.hs +++ b/generator/src/Test/Pos/Block/Logic/Event.hs @@ -21,7 +21,7 @@ import qualified Data.Text as T import Pos.Block.Logic.VAR (BlockLrcMode, rollbackBlocks, verifyAndApplyBlocks) import Pos.Block.Types (Blund) -import Pos.Core (HasConfiguration, HeaderHash) +import Pos.Core (HeaderHash) import Pos.Core.Chrono (NE, OldestFirst) import Pos.DB.Pure (DBPureDiff, MonadPureDB, dbPureDiff, dbPureDump, dbPureReset) @@ -37,6 +37,7 @@ import Pos.Util.Util (eitherToThrow, lensOf) import Test.Pos.Block.Logic.Mode (BlockTestContext, PureDBSnapshotsVar (..)) import Test.Pos.Block.Logic.Util (satisfySlotCheck) +import Test.Pos.Core.Dummy (dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) data SnapshotMissingEx = SnapshotMissingEx SnapshotId @@ -56,20 +57,20 @@ data BlockEventResult | BlockEventFailure IsExpected SomeException | BlockEventDbChanged DbNotEquivalentToSnapshot -verifyAndApplyBlocks' :: - ( HasConfiguration - , BlockLrcMode BlockTestContext m - , MonadTxpLocal m - ) +verifyAndApplyBlocks' + :: (BlockLrcMode BlockTestContext m, MonadTxpLocal m) => OldestFirst NE Blund -> m () verifyAndApplyBlocks' blunds = do satisfySlotCheck blocks $ do - (_ :: HeaderHash) <- eitherToThrow =<< - verifyAndApplyBlocks dummyProtocolMagic True blocks + (_ :: HeaderHash) <- + eitherToThrow + =<< verifyAndApplyBlocks dummyProtocolMagic + dummyProtocolConstants + True + blocks return () - where - blocks = fst <$> blunds + where blocks = fst <$> blunds -- | Execute a single block event. runBlockEvent :: @@ -91,7 +92,7 @@ runBlockEvent (BlkEvApply ev) = BlockApplyFailure -> BlockEventFailure (IsExpected True) e runBlockEvent (BlkEvRollback ev) = - (onSuccess <$ rollbackBlocks dummyProtocolMagic (ev ^. berInput)) + (onSuccess <$ rollbackBlocks dummyProtocolMagic dummyProtocolConstants (ev ^. berInput)) `catch` (return . onFailure) where onSuccess = case ev ^. berOutValid of diff --git a/generator/src/Test/Pos/Block/Logic/Mode.hs b/generator/src/Test/Pos/Block/Logic/Mode.hs index 87773c12d4f..dfca457a1e3 100644 --- a/generator/src/Test/Pos/Block/Logic/Mode.hs +++ b/generator/src/Test/Pos/Block/Logic/Mode.hs @@ -64,12 +64,10 @@ import Pos.Block.BListener (MonadBListener (..), onApplyBlocksStub, import Pos.Block.Slog (HasSlogGState (..), mkSlogGState) import Pos.Core (BlockVersionData, CoreConfiguration (..), GenesisConfiguration (..), GenesisInitializer (..), - GenesisSpec (..), HasConfiguration, HasProtocolConstants, - SlotId, Timestamp (..), epochSlots, genesisSecretKeys, - withGenesisSpec) + GenesisSpec (..), HasConfiguration, SlotId, + Timestamp (..), genesisSecretKeys, withGenesisSpec) import Pos.Core.Configuration (HasGenesisBlockVersionData, withGenesisBlockVersionData) -import Pos.Crypto (ProtocolMagic) import Pos.DB (DBPure, MonadDB (..), MonadDBRead (..), MonadGState (..)) import qualified Pos.DB as DB @@ -114,6 +112,7 @@ import Test.Pos.Block.Logic.Emulation (Emulation (..), runEmulation, sudoLiftIO) import Test.Pos.Configuration (defaultTestBlockVersionData, defaultTestConf, defaultTestGenesisSpec) +import Test.Pos.Core.Dummy (dummyEpochSlots, dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) ---------------------------------------------------------------------------- @@ -167,16 +166,16 @@ genGenesisInitializer = do -- This function creates 'CoreConfiguration' from 'TestParams' and -- uses it to satisfy 'HasConfiguration'. -withTestParams :: TestParams -> (HasConfiguration => ProtocolMagic -> r) -> r -withTestParams TestParams {..} = withGenesisSpec _tpStartTime coreConfiguration +withTestParams :: TestParams -> (HasConfiguration => r) -> r +withTestParams TestParams {..} f = + withGenesisSpec _tpStartTime coreConfiguration $ \_ _ -> f where defaultCoreConf :: CoreConfiguration defaultCoreConf = ccCore defaultTestConf coreConfiguration :: CoreConfiguration - coreConfiguration = defaultCoreConf {ccGenesis = GCSpec genesisSpec} - genesisSpec = - defaultTestGenesisSpec - { gsInitializer = _tpGenesisInitializer + coreConfiguration = defaultCoreConf { ccGenesis = GCSpec genesisSpec } + genesisSpec = defaultTestGenesisSpec + { gsInitializer = _tpGenesisInitializer , gsBlockVersionData = _tpBlockVersionData } @@ -253,7 +252,7 @@ initBlockTestContext tp@TestParams {..} callback = do (futureLrcCtx, putLrcCtx) <- newInitFuture "lrcCtx" (futureSlottingVar, putSlottingVar) <- newInitFuture "slottingVar" systemStart <- Timestamp <$> currentTime - slottingState <- mkSimpleSlottingStateVar + slottingState <- mkSimpleSlottingStateVar dummyEpochSlots let initCtx = TestInitModeContext dbPureVar @@ -262,15 +261,15 @@ initBlockTestContext tp@TestParams {..} callback = do systemStart futureLrcCtx initBlockTestContextDo = do - initNodeDBs dummyProtocolMagic epochSlots + initNodeDBs dummyProtocolMagic dummyProtocolConstants _gscSlottingVar <- newTVarIO =<< GS.getSlottingData putSlottingVar _gscSlottingVar let btcLoggerName = "testing" lcLrcSync <- mkLrcSyncData >>= newTVarIO let _gscLrcContext = LrcContext {..} putLrcCtx _gscLrcContext - btcUpdateContext <- mkUpdateContext - btcSscState <- mkSscState + btcUpdateContext <- mkUpdateContext dummyEpochSlots + btcSscState <- mkSscState dummyEpochSlots _gscSlogGState <- mkSlogGState btcTxpMem <- mkTxpLocalData let btcTxpGlobalSettings = txpGlobalSettings dummyProtocolMagic @@ -325,9 +324,8 @@ blockPropertyToProperty -> (HasConfiguration => BlockProperty a) -> Property blockPropertyToProperty tpGen blockProperty = - forAll tpGen $ \tp -> - withTestParams tp $ \_ -> - monadic (ioProperty . runBlockTestMode tp) blockProperty + forAll tpGen $ \tp -> withTestParams tp + $ monadic (ioProperty . runBlockTestMode tp) blockProperty -- | Simplified version of 'blockPropertyToProperty' which uses -- 'Arbitrary' instance to generate 'TestParams'. @@ -376,9 +374,7 @@ instance HasConfiguration => MonadDB TestInitMode where dbDelete = DB.dbDeletePureDefault dbPutSerBlunds = DB.dbPutSerBlundsPureDefault -instance (HasConfiguration, MonadSlotsData ctx TestInitMode) - => MonadSlots ctx TestInitMode - where +instance MonadSlotsData ctx TestInitMode => MonadSlots ctx TestInitMode where getCurrentSlot = getCurrentSlotSimple getCurrentSlotBlocking = getCurrentSlotBlockingSimple getCurrentSlotInaccurate = getCurrentSlotInaccurateSimple @@ -477,23 +473,26 @@ testSlottingHelper targetF alternative = do Nothing -> targetF btcSSlottingStateVar Just slot -> pure $ alternative slot -getCurrentSlotTestDefault :: (TestSlottingContext ctx m, HasProtocolConstants) => m (Maybe SlotId) -getCurrentSlotTestDefault = testSlottingHelper getCurrentSlotSimple' Just +getCurrentSlotTestDefault :: TestSlottingContext ctx m => m (Maybe SlotId) +getCurrentSlotTestDefault = + testSlottingHelper (getCurrentSlotSimple' dummyEpochSlots) Just -getCurrentSlotBlockingTestDefault :: (TestSlottingContext ctx m, HasProtocolConstants) => m SlotId -getCurrentSlotBlockingTestDefault = testSlottingHelper getCurrentSlotBlockingSimple' identity +getCurrentSlotBlockingTestDefault :: TestSlottingContext ctx m => m SlotId +getCurrentSlotBlockingTestDefault = + testSlottingHelper (getCurrentSlotBlockingSimple' dummyEpochSlots) identity -getCurrentSlotInaccurateTestDefault :: (TestSlottingContext ctx m, HasProtocolConstants) => m SlotId -getCurrentSlotInaccurateTestDefault = testSlottingHelper getCurrentSlotInaccurateSimple' identity +getCurrentSlotInaccurateTestDefault :: TestSlottingContext ctx m => m SlotId +getCurrentSlotInaccurateTestDefault = testSlottingHelper + (getCurrentSlotInaccurateSimple' dummyEpochSlots) + identity currentTimeSlottingTestDefault :: SimpleSlottingMode ctx m => m Timestamp currentTimeSlottingTestDefault = currentTimeSlottingSimple -instance (HasConfiguration, MonadSlotsData ctx BlockTestMode) - => MonadSlots ctx BlockTestMode where - getCurrentSlot = getCurrentSlotTestDefault - getCurrentSlotBlocking = getCurrentSlotBlockingTestDefault - getCurrentSlotInaccurate = getCurrentSlotInaccurateTestDefault +instance MonadSlotsData ctx BlockTestMode => MonadSlots ctx BlockTestMode where + getCurrentSlot = const getCurrentSlotTestDefault + getCurrentSlotBlocking = const getCurrentSlotBlockingTestDefault + getCurrentSlotInaccurate = const getCurrentSlotInaccurateTestDefault currentTimeSlotting = currentTimeSlottingTestDefault instance HasConfiguration => MonadDBRead BlockTestMode where @@ -513,7 +512,7 @@ instance HasConfiguration => MonadGState BlockTestMode where instance MonadBListener BlockTestMode where onApplyBlocks = onApplyBlocksStub - onRollbackBlocks = onRollbackBlocksStub + onRollbackBlocks _ = onRollbackBlocksStub type instance MempoolExt BlockTestMode = EmptyMempoolExt diff --git a/generator/src/Test/Pos/Block/Logic/Util.hs b/generator/src/Test/Pos/Block/Logic/Util.hs index e353aa1008c..a2daef6fb41 100644 --- a/generator/src/Test/Pos/Block/Logic/Util.hs +++ b/generator/src/Test/Pos/Block/Logic/Util.hs @@ -25,18 +25,20 @@ import Test.QuickCheck.Monadic (PropertyM, pick) import Pos.AllSecrets (AllSecrets, HasAllSecrets (..), allSecrets) import Pos.Block.Types (Blund) import Pos.Core (BlockCount, GenesisData (..), HasGenesisData, - HasProtocolConstants, SlotId (..), epochIndexL, - genesisData) + SlotId (..), epochIndexL, genesisData, + localSlotIndexMinBound) import Pos.Core.Block (Block) import Pos.Core.Chrono (NE, OldestFirst (..)) -import Pos.Crypto (ProtocolMagic) import Pos.Generator.Block (BlockGenMode, BlockGenParams (..), MonadBlockGenInit, genBlocks, tgpTxCountRange) import Pos.Txp (HasTxpConfiguration, MempoolExt, MonadTxpLocal, TxpGlobalSettings, txpGlobalSettings) import Pos.Util (HasLens', _neLast) + import Test.Pos.Block.Logic.Mode (BlockProperty, BlockTestContext, btcSlotIdL) +import Test.Pos.Core.Dummy (dummyProtocolConstants) +import Test.Pos.Crypto.Dummy (dummyProtocolMagic) -- | Wrapper for 'bpGenBlocks' to clarify the meaning of the argument. newtype EnableTxPayload = EnableTxPayload Bool @@ -53,12 +55,11 @@ genBlockGenParams , HasAllSecrets ctx , MonadReader ctx m ) - => ProtocolMagic - -> Maybe BlockCount + => Maybe BlockCount -> EnableTxPayload -> InplaceDB -> PropertyM m BlockGenParams -genBlockGenParams pm blkCnt (EnableTxPayload enableTxPayload) (InplaceDB inplaceDB) = do +genBlockGenParams blkCnt (EnableTxPayload enableTxPayload) (InplaceDB inplaceDB) = do allSecrets_ <- lift $ getAllSecrets let genStakeholders = gdBootStakeholders genesisData let genBlockGenParamsF s = @@ -71,7 +72,7 @@ genBlockGenParams pm blkCnt (EnableTxPayload enableTxPayload) (InplaceDB inplace , _bgpInplaceDB = inplaceDB , _bgpGenStakeholders = genStakeholders , _bgpSkipNoKey = False - , _bgpTxpGlobalSettings = txpGlobalSettings pm + , _bgpTxpGlobalSettings = txpGlobalSettings dummyProtocolMagic } pick $ sized genBlockGenParamsF @@ -87,15 +88,22 @@ bpGenBlocks , MonadTxpLocal (BlockGenMode (MempoolExt m) m) , HasAllSecrets ctx ) - => ProtocolMagic - -> Maybe BlockCount + => Maybe BlockCount -> EnableTxPayload -> InplaceDB -> PropertyM m (OldestFirst [] Blund) -bpGenBlocks pm blkCnt enableTxPayload inplaceDB = do - params <- genBlockGenParams pm blkCnt enableTxPayload inplaceDB - g <- pick $ MkGen $ \qc _ -> qc - lift $ OldestFirst <$> evalRandT (genBlocks pm params maybeToList) g +bpGenBlocks blkCnt enableTxPayload inplaceDB = do + params <- genBlockGenParams blkCnt enableTxPayload inplaceDB + g <- pick $ MkGen $ \qc _ -> qc + lift + $ OldestFirst + <$> evalRandT + (genBlocks dummyProtocolMagic + dummyProtocolConstants + params + maybeToList + ) + g -- | A version of 'bpGenBlocks' which generates exactly one -- block. Allows one to avoid unsafe functions sometimes. @@ -107,9 +115,11 @@ bpGenBlock , HasAllSecrets ctx , Default (MempoolExt m) ) - => ProtocolMagic -> EnableTxPayload -> InplaceDB -> PropertyM m Blund + => EnableTxPayload + -> InplaceDB + -> PropertyM m Blund -- 'unsafeHead' is safe because we create exactly 1 block -bpGenBlock pm = fmap (List.head . toList) ... bpGenBlocks pm (Just 1) +bpGenBlock = fmap (List.head . toList) ... bpGenBlocks (Just 1) getAllSecrets :: (MonadReader ctx m, HasAllSecrets ctx) => m AllSecrets getAllSecrets = view allSecrets @@ -128,10 +138,10 @@ withCurrentSlot slot = local (set btcSlotIdL $ Just slot) -- future. This function pretends that current slot is after the last -- slot of the given blocks. satisfySlotCheck - :: ( HasProtocolConstants, MonadReader BlockTestContext m) + :: MonadReader BlockTestContext m => OldestFirst NE Block -> m a -> m a satisfySlotCheck (OldestFirst blocks) action = let lastEpoch = blocks ^. _neLast . epochIndexL - in withCurrentSlot (SlotId (lastEpoch + 1) minBound) action + in withCurrentSlot (SlotId (lastEpoch + 1) localSlotIndexMinBound) action diff --git a/generator/test/Test/Pos/Binary/CommunicationSpec.hs b/generator/test/Test/Pos/Binary/CommunicationSpec.hs index 3e02b953744..9ff98609d48 100644 --- a/generator/test/Test/Pos/Binary/CommunicationSpec.hs +++ b/generator/test/Test/Pos/Binary/CommunicationSpec.hs @@ -21,16 +21,14 @@ import Test.Pos.Block.Logic.Util (EnableTxPayload (..), InplaceDB (..), bpGenBlock) import Test.Pos.Configuration (HasStaticConfigurations, withStaticConfigurations) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) -- | -- The binary encoding of `MsgSerializedBlock` using `serializeMsgSerializedBlock` -- should be the same as the binary encoding of `MsgBlock`. -serializeMsgSerializedBlockSpec - :: (HasStaticConfigurations) => Spec +serializeMsgSerializedBlockSpec :: HasStaticConfigurations => Spec serializeMsgSerializedBlockSpec = do prop desc $ blockPropertyTestable $ do - (block, _) <- bpGenBlock dummyProtocolMagic (EnableTxPayload True) (InplaceDB True) + (block, _) <- bpGenBlock (EnableTxPayload True) (InplaceDB True) let sb = Serialized $ serialize' block assert $ serializeMsgSerializedBlock (MsgSerializedBlock sb) == serialize' (MsgBlock block) prop descNoBlock $ blockPropertyTestable $ do @@ -47,11 +45,10 @@ serializeMsgSerializedBlockSpec = do -- | -- Deserialization of a serialized `MsgSerializedBlock` (with -- `serializeMsgSerializedBlock`) should give back the original block. -deserializeSerilizedMsgSerializedBlockSpec - :: (HasStaticConfigurations) => Spec +deserializeSerilizedMsgSerializedBlockSpec :: HasStaticConfigurations => Spec deserializeSerilizedMsgSerializedBlockSpec = do prop desc $ blockPropertyTestable $ do - (block, _) <- bpGenBlock dummyProtocolMagic (EnableTxPayload True) (InplaceDB True) + (block, _) <- bpGenBlock (EnableTxPayload True) (InplaceDB True) let sb = Serialized $ serialize' block let msg :: Either Text MsgBlock msg = decodeFull . BSL.fromStrict . serializeMsgSerializedBlock $ MsgSerializedBlock sb diff --git a/generator/test/Test/Pos/Block/Logic/CreationSpec.hs b/generator/test/Test/Pos/Block/Logic/CreationSpec.hs index 98998ba77a3..434c66aeb5a 100644 --- a/generator/test/Test/Pos/Block/Logic/CreationSpec.hs +++ b/generator/test/Test/Pos/Block/Logic/CreationSpec.hs @@ -20,10 +20,9 @@ import Pos.Arbitrary.Ssc (commitmentMapEpochGen, import Pos.Binary.Class (biSize) import Pos.Block.Logic (RawPayload (..), createMainBlockPure) import qualified Pos.Communication () -import Pos.Core (BlockVersionData (bvdMaxBlockSize), HasConfiguration, - SlotId (..), blkSecurityParam, genesisBlockVersionData, - mkVssCertificatesMapLossy, protocolConstants, - unsafeMkLocalSlotIndex) +import Pos.Core (BlockVersionData (bvdMaxBlockSize), SlotId (..), + genesisBlockVersionData, localSlotIndexMinBound, + mkVssCertificatesMapLossy, unsafeMkLocalSlotIndex) import Pos.Core.Block (BlockHeader, MainBlock) import Pos.Core.Ssc (SscPayload (..)) import Pos.Core.Txp (TxAux) @@ -36,13 +35,15 @@ import Pos.Update.Configuration (HasUpdateConfiguration) import Test.Pos.Block.Arbitrary () import Test.Pos.Configuration (withDefConfiguration, withDefUpdateConfiguration) +import Test.Pos.Core.Dummy (dummyEpochSlots, dummyK, + dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Delegation.Arbitrary (genDlgPayload) import Test.Pos.Txp.Arbitrary (GoodTx, goodTxToTxAux) import Test.Pos.Util.QuickCheck (SmallGenerator (..), makeSmall) spec :: Spec -spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ +spec = withDefConfiguration $ withDefUpdateConfiguration $ describe "Block.Logic.Creation" $ do -- Sampling the minimum empty block size @@ -58,6 +59,7 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ emptyBSize = round $ (1.5 * fromIntegral emptyBSize0 :: Double) describe "createMainBlockPure" $ modifyMaxSuccess (const 1000) $ do + prop "empty block size is sane" $ emptyBlk $ \blk0 -> leftToCounter blk0 $ \blk -> let s = biSize blk in counterexample ("Real block size: " <> show s <> @@ -67,6 +69,7 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ -- Empirically, empty blocks don't get bigger than 550 -- bytes. s <= 550 && s <= bvdMaxBlockSize genesisBlockVersionData + prop "doesn't create blocks bigger than the limit" $ forAll (choose (emptyBSize, emptyBSize * 10)) $ \(fromBytes -> limit) -> forAll arbitrary $ \(prevHeader, sk, updatePayload) -> @@ -79,6 +82,7 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ let s = biSize b in counterexample ("Real block size: " <> show s) $ s <= fromIntegral limit + prop "removes transactions when necessary" $ forAll arbitrary $ \(prevHeader, sk) -> forAll (makeSmall $ listOf1 genTxAux) $ \txs -> @@ -91,6 +95,7 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ blk2 = noSscBlock s prevHeader txs def def sk in counterexample ("Tested with block size limit: " <> show s) $ leftToCounter blk2 (const True) + prop "strips ssc data when necessary" $ forAll arbitrary $ \(prevHeader, sk) -> forAll validSscPayloadGen $ \(sscPayload, slotId) -> @@ -106,67 +111,99 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ blk2 = withPayload s in counterexample ("Tested with block size limit: " <> show s) $ leftToCounter blk2 (const True) - where - defSscPld :: HasConfiguration => SlotId -> SscPayload - defSscPld sId = defaultSscPayload $ siSlot sId - - infLimit = convertUnit @Gigabyte @Byte 1 - - leftToCounter :: (ToString s, Testable p) => Either s a -> (a -> p) -> Property - leftToCounter x c = either (\t -> counterexample (toString t) False) (property . c) x - - emptyBlk - :: (HasConfiguration, HasUpdateConfiguration, Testable p) - => (Either Text MainBlock -> p) - -> Property - emptyBlk foo = - forAll arbitrary $ \(prevHeader, sk, slotId) -> - foo $ producePureBlock infLimit prevHeader [] Nothing slotId def (defSscPld slotId) def sk - - genTxAux :: Gen TxAux - genTxAux = - goodTxToTxAux . getSmallGenerator <$> (arbitrary :: Gen (SmallGenerator GoodTx)) - - noSscBlock - :: (HasConfiguration, HasUpdateConfiguration) - => Byte - -> BlockHeader - -> [TxAux] - -> DlgPayload - -> UpdatePayload - -> SecretKey - -> Either Text MainBlock - noSscBlock limit prevHeader txs proxyCerts updatePayload sk = - let neutralSId = SlotId 0 (unsafeMkLocalSlotIndex $ fromIntegral $ blkSecurityParam * 2) - in producePureBlock - limit prevHeader txs Nothing neutralSId proxyCerts (defSscPld neutralSId) updatePayload sk - - producePureBlock - :: (HasConfiguration, HasUpdateConfiguration) - => Byte - -> BlockHeader - -> [TxAux] - -> ProxySKBlockInfo - -> SlotId - -> DlgPayload - -> SscPayload - -> UpdatePayload - -> SecretKey - -> Either Text MainBlock - producePureBlock limit prev txs psk slot dlgPay sscPay usPay sk = - createMainBlockPure dummyProtocolMagic limit prev psk slot sk $ - RawPayload txs sscPay dlgPay usPay - -validSscPayloadGen :: HasConfiguration => Gen (SscPayload, SlotId) + +defSscPld :: SlotId -> SscPayload +defSscPld sId = defaultSscPayload dummyK $ siSlot sId + +infLimit :: Byte +infLimit = convertUnit @Gigabyte @Byte 1 + +leftToCounter :: (ToString s, Testable p) => Either s a -> (a -> p) -> Property +leftToCounter x c = + either (\t -> counterexample (toString t) False) (property . c) x + +emptyBlk + :: (HasUpdateConfiguration, Testable p) + => (Either Text MainBlock -> p) + -> Property +emptyBlk foo = + forAll arbitrary $ \(prevHeader, sk, slotId) -> foo $ producePureBlock + infLimit + prevHeader + [] + Nothing + slotId + def + (defSscPld slotId) + def + sk + +genTxAux :: Gen TxAux +genTxAux = + goodTxToTxAux + . getSmallGenerator + <$> (arbitrary :: Gen (SmallGenerator GoodTx)) + +noSscBlock + :: HasUpdateConfiguration + => Byte + -> BlockHeader + -> [TxAux] + -> DlgPayload + -> UpdatePayload + -> SecretKey + -> Either Text MainBlock +noSscBlock limit prevHeader txs proxyCerts updatePayload sk = + let neutralSId = SlotId + 0 + (unsafeMkLocalSlotIndex dummyEpochSlots $ fromIntegral $ dummyK * 2) + in producePureBlock limit + prevHeader + txs + Nothing + neutralSId + proxyCerts + (defSscPld neutralSId) + updatePayload + sk + +producePureBlock + :: HasUpdateConfiguration + => Byte + -> BlockHeader + -> [TxAux] + -> ProxySKBlockInfo + -> SlotId + -> DlgPayload + -> SscPayload + -> UpdatePayload + -> SecretKey + -> Either Text MainBlock +producePureBlock limit prev txs psk slot dlgPay sscPay usPay sk = + createMainBlockPure dummyProtocolMagic dummyK limit prev psk slot sk + $ RawPayload txs sscPay dlgPay usPay + +validSscPayloadGen :: Gen (SscPayload, SlotId) validSscPayloadGen = do - vssCerts <- makeSmall $ fmap mkVssCertificatesMapLossy $ listOf $ - vssCertificateEpochGen dummyProtocolMagic protocolConstants 0 - let mkSlot i = SlotId 0 (unsafeMkLocalSlotIndex (fromIntegral i)) - oneof [ do commMap <- makeSmall $ commitmentMapEpochGen dummyProtocolMagic 0 - pure (CommitmentsPayload commMap vssCerts, SlotId 0 minBound) - , do openingsMap <- makeSmall arbitrary - pure (OpeningsPayload openingsMap vssCerts, mkSlot (4 * blkSecurityParam + 1)) - , do sharesMap <- makeSmall arbitrary - pure (SharesPayload sharesMap vssCerts, mkSlot (8 * blkSecurityParam)) - , pure (CertificatesPayload vssCerts, mkSlot (7 * blkSecurityParam)) - ] + vssCerts <- + makeSmall + $ fmap mkVssCertificatesMapLossy + $ listOf + $ vssCertificateEpochGen dummyProtocolMagic dummyProtocolConstants 0 + let mkSlot i = + SlotId 0 (unsafeMkLocalSlotIndex dummyEpochSlots (fromIntegral i)) + oneof + [ do + commMap <- makeSmall $ commitmentMapEpochGen dummyProtocolMagic 0 + pure + ( CommitmentsPayload commMap vssCerts + , SlotId 0 localSlotIndexMinBound + ) + , do + openingsMap <- makeSmall arbitrary + pure (OpeningsPayload openingsMap vssCerts, mkSlot (4 * dummyK + 1)) + , do + sharesMap <- makeSmall arbitrary + pure (SharesPayload sharesMap vssCerts, mkSlot (8 * dummyK)) + , pure (CertificatesPayload vssCerts, mkSlot (7 * dummyK)) + ] diff --git a/generator/test/Test/Pos/Block/Logic/VarSpec.hs b/generator/test/Test/Pos/Block/Logic/VarSpec.hs index 480a66d2fba..27a0068c644 100644 --- a/generator/test/Test/Pos/Block/Logic/VarSpec.hs +++ b/generator/test/Test/Pos/Block/Logic/VarSpec.hs @@ -24,8 +24,8 @@ import Test.QuickCheck.Random (QCGen) import Pos.Block.Logic (verifyAndApplyBlocks, verifyBlocksPrefix) import Pos.Block.Types (Blund) -import Pos.Core (GenesisData (..), HasConfiguration, blkSecurityParam, - epochSlots, genesisData, headerHash) +import Pos.Core (GenesisData (..), HasConfiguration, + ProtocolConstants (..), genesisData, headerHash) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), nonEmptyNewestFirst, nonEmptyOldestFirst, splitAtNewestFirst, toNewestFirst, _NewestFirst) @@ -48,6 +48,8 @@ import Test.Pos.Block.Logic.Util (EnableTxPayload (..), import Test.Pos.Block.Property (blockPropertySpec) import Test.Pos.Configuration (HasStaticConfigurations, withStaticConfigurations) +import Test.Pos.Core.Dummy (dummyEpochSlots, dummyK, + dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Property (splitIntoChunks, stopProperty) @@ -73,8 +75,7 @@ spec = withStaticConfigurations $ \_ -> -- verifyBlocksPrefix ---------------------------------------------------------------------------- -verifyBlocksPrefixSpec - :: HasStaticConfigurations => Spec +verifyBlocksPrefixSpec :: HasStaticConfigurations => Spec verifyBlocksPrefixSpec = do blockPropertySpec verifyEmptyMainBlockDesc verifyEmptyMainBlock blockPropertySpec verifyValidBlocksDesc verifyValidBlocks @@ -91,18 +92,19 @@ verifyBlocksPrefixSpec = do verifyEmptyMainBlock :: HasConfigurations => BlockProperty () verifyEmptyMainBlock = do - emptyBlock <- fst <$> bpGenBlock dummyProtocolMagic - (EnableTxPayload False) - (InplaceDB False) - whenLeftM (lift $ verifyBlocksPrefix dummyProtocolMagic (one emptyBlock)) + emptyBlock <- fst <$> bpGenBlock (EnableTxPayload False) (InplaceDB False) + whenLeftM + (lift $ verifyBlocksPrefix dummyProtocolMagic + dummyProtocolConstants + (one emptyBlock) + ) $ stopProperty . pretty verifyValidBlocks :: HasConfigurations => BlockProperty () verifyValidBlocks = do bpGoToArbitraryState - blocks <- map fst . toList <$> bpGenBlocks dummyProtocolMagic - Nothing + blocks <- map fst . toList <$> bpGenBlocks Nothing (EnableTxPayload True) (InplaceDB False) pre (not $ null blocks) @@ -114,6 +116,7 @@ verifyValidBlocks = do in block0 :| otherBlocks' verRes <- lift $ satisfySlotCheck blocksToVerify $ verifyBlocksPrefix dummyProtocolMagic + dummyProtocolConstants blocksToVerify whenLeft verRes $ stopProperty . pretty @@ -129,7 +132,7 @@ verifyAndApplyBlocksSpec = applier blunds = let blocks = map fst blunds in satisfySlotCheck blocks $ - whenLeftM (verifyAndApplyBlocks dummyProtocolMagic True blocks) throwM + whenLeftM (verifyAndApplyBlocks dummyProtocolMagic dummyProtocolConstants True blocks) throwM applyByOneOrAllAtOnceDesc = "verifying and applying blocks one by one leads " <> "to the same GState as verifying and applying them all at once " <> @@ -162,10 +165,8 @@ applyByOneOrAllAtOnce -> BlockProperty () applyByOneOrAllAtOnce applier = do bpGoToArbitraryState - blunds <- getOldestFirst <$> bpGenBlocks dummyProtocolMagic - Nothing - (EnableTxPayload True) - (InplaceDB False) + blunds <- getOldestFirst + <$> bpGenBlocks Nothing (EnableTxPayload True) (InplaceDB False) pre (not $ null blunds) let blundsNE = OldestFirst (NE.fromList blunds) stateAfter1by1 <- lift $ GS.withClonedGState $ do @@ -224,47 +225,63 @@ blockEventSuccessSpec = and a few sheets of paper trying to figure out how to write it. -} -genSuccessWithForks :: forall g m. (HasConfiguration, RandomGen g, Monad m) => BlockEventGenT g m () +genSuccessWithForks + :: forall g m . (RandomGen g, Monad m) => BlockEventGenT g m () genSuccessWithForks = do - emitBlockApply BlockApplySuccess $ pathSequence mempty ["0"] - generateFork "0" [] - emitBlockApply BlockApplySuccess $ pathSequence "0" ["1", "2"] - generateFork ("0" <> "1" <> "2") [] + emitBlockApply BlockApplySuccess $ pathSequence mempty ["0"] + generateFork "0" [] + emitBlockApply BlockApplySuccess $ pathSequence "0" ["1", "2"] + generateFork ("0" <> "1" <> "2") [] where - generateFork :: - Path -- base path (from the main chain) + generateFork + :: Path -- base path (from the main chain) -> NewestFirst [] Path -- current fork state -> BlockEventGenT g m () generateFork basePath rollbackFork = do - let - forkLen = length rollbackFork - wiggleRoom = fromIntegral blkSecurityParam - forkLen + let forkLen = length rollbackFork + wiggleRoom = fromIntegral dummyK - forkLen stopFork <- byChance (if forkLen > 0 then 0.1 else 0) if stopFork - then whenJust (nonEmptyNewestFirst rollbackFork) $ - emitBlockRollback BlockRollbackSuccess + then whenJust (nonEmptyNewestFirst rollbackFork) + $ emitBlockRollback BlockRollbackSuccess else do needRollback <- -- forkLen=0 => needRollback 0% -- forkLen=blkSecurityParam => needRollback 100% - byChance (realToFrac $ forkLen Ratio.% fromIntegral blkSecurityParam) + byChance + (realToFrac $ forkLen Ratio.% fromIntegral dummyK) if needRollback then do retreat <- getRandomR (1, forkLen) - whenJust (nonEmptyNewestFirst rollbackFork) $ \rollbackFork' -> do + whenJust (nonEmptyNewestFirst rollbackFork) + $ \rollbackFork' -> do -- forkLen > 0, therefore retreat > 0 - let (over _NewestFirst NE.fromList -> before, after) = splitAtNewestFirst retreat rollbackFork' - emitBlockRollback BlockRollbackSuccess before - generateFork basePath after + let + (over _NewestFirst NE.fromList -> before, after) + = splitAtNewestFirst retreat + rollbackFork' + emitBlockRollback BlockRollbackSuccess before + generateFork basePath after else do - advance <- getRandomR (1, wiggleRoom) - relPaths <- OldestFirst <$> replicateM advance generateRelativePath1 - whenJust (nonEmptyOldestFirst relPaths) $ \relPaths' -> do - let - curPath = maybe basePath NE.head $ nonEmpty (getNewestFirst rollbackFork) - paths = pathSequence curPath relPaths' - emitBlockApply BlockApplySuccess paths - generateFork basePath (over _NewestFirst toList (toNewestFirst paths) <> rollbackFork) + advance <- getRandomR (1, wiggleRoom) + relPaths <- + OldestFirst + <$> replicateM advance generateRelativePath1 + whenJust (nonEmptyOldestFirst relPaths) $ \relPaths' -> + do + let + curPath = + maybe basePath NE.head $ nonEmpty + (getNewestFirst rollbackFork) + paths = pathSequence curPath relPaths' + emitBlockApply BlockApplySuccess paths + generateFork + basePath + ( over _NewestFirst + toList + (toNewestFirst paths) + <> rollbackFork + ) generateRelativePath1 :: BlockEventGenT g m Path generateRelativePath1 = uniform (["rekt", "kek", "mems", "peka"] :: NE Path) @@ -278,6 +295,7 @@ blockPropertyScenarioGen m = do let genStakeholders = gdBootStakeholders genesisData g <- pick $ MkGen $ \qc _ -> qc lift $ flip evalRandT g $ runBlockEventGenT dummyProtocolMagic + dummyProtocolConstants allSecrets genStakeholders m @@ -334,7 +352,7 @@ applyThroughEpochProp afterCross = do let approachEpochEdge = pathSequence mempty . OldestFirst . NE.fromList $ - replicate (fromIntegral epochSlots - 1) "a" + replicate (fromIntegral dummyEpochSlots - 1) "a" crossEpochEdge = pathSequence (NE.last $ getOldestFirst approachEpochEdge) $ OldestFirst . NE.fromList $ @@ -364,26 +382,25 @@ singleForkProp fd = do data ForkDepth = ForkShort | ForkMedium | ForkDeep -genSingleFork :: forall g m. (HasConfigurations, RandomGen g, Monad m) - => ForkDepth -> BlockEventGenT g m () +genSingleFork + :: forall g m . (RandomGen g, Monad m) => ForkDepth -> BlockEventGenT g m () genSingleFork fd = do - let k = fromIntegral blkSecurityParam :: Int + let k = pcK dummyProtocolConstants -- 'd' is how deeply in the chain the fork starts. In other words, it's how many -- blocks we're going to rollback (therefore must be >1). d <- getRandomR $ case fd of - ForkShort -> (1, if k > 1 then k-1 else 1) - ForkMedium -> (if k > 2 then k - 2 else 1, k+2) - ForkDeep -> (k+1, div (k*3) 2 + 1) + ForkShort -> (1, if k > 1 then k - 1 else 1) + ForkMedium -> (if k > 2 then k - 2 else 1, k + 2) + ForkDeep -> (k + 1, div (k * 3) 2 + 1) -- the depth must be <=k for a successful rollback. let expectSuccess = d <= k -- original blockchain max index q<(9.5*k) - q <- getRandomR (d+1, 9 * k + div k 2) - let - -- max index of the common prefix. i>0 because d0 because di. the upper bound is arbitrary. -- dj=j-i - dj <- getRandomR (1, d*2) + dj <- getRandomR (1, d * 2) -- now we can generate paths: -- -- B0 - B1 - B2 - B3 - B4 - B5 - B6 - B7 @@ -394,18 +411,31 @@ genSingleFork fd = do let nonEmptyCuz r [] = error ("Requirement failed: " <> r) nonEmptyCuz _ xs = NE.fromList xs - commonPrefix = pathSequence mempty $ - OldestFirst . nonEmptyCuz "i > 0" $ replicate i "B" - originalChain = pathSequence mempty $ - OldestFirst . nonEmptyCuz "q > 0" $ replicate q "B" - rollbackChain = toNewestFirst . pathSequence (stimes i "B") $ - OldestFirst . nonEmptyCuz "d > 0" $ replicate d "B" - forkChain = pathSequence (NE.last $ getOldestFirst commonPrefix) $ - OldestFirst . nonEmptyCuz "dj > 0" $ replicate dj "C" + commonPrefix = + pathSequence mempty $ OldestFirst . nonEmptyCuz "i > 0" $ replicate + i + "B" + originalChain = + pathSequence mempty $ OldestFirst . nonEmptyCuz "q > 0" $ replicate + q + "B" + rollbackChain = + toNewestFirst + . pathSequence (stimes i "B") + $ OldestFirst + . nonEmptyCuz "d > 0" + $ replicate d "B" + forkChain = + pathSequence (NE.last $ getOldestFirst commonPrefix) + $ OldestFirst + . nonEmptyCuz "dj > 0" + $ replicate dj "C" emitBlockApply BlockApplySuccess originalChain if expectSuccess then do emitBlockRollback BlockRollbackSuccess rollbackChain - emitBlockApply BlockApplySuccess forkChain + emitBlockApply BlockApplySuccess forkChain else do - emitBlockRollback (BlockRollbackFailure BlkRbSecurityLimitExceeded) rollbackChain + emitBlockRollback + (BlockRollbackFailure BlkRbSecurityLimitExceeded) + rollbackChain diff --git a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs index 5060f1f8451..3cbf12a817a 100644 --- a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs +++ b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs @@ -26,9 +26,8 @@ import qualified Pos.Block.Lrc as Lrc import Pos.Block.Slog (ShouldCallBListener (..)) import Pos.Core (Coin, EpochIndex, GenesisData (..), GenesisInitializer (..), StakeholderId, - TestnetBalanceOptions (..), addressHash, blkSecurityParam, - coinF, epochSlots, genesisData, genesisSecretKeysPoor, - genesisSecretKeysRich) + TestnetBalanceOptions (..), addressHash, coinF, + genesisData, genesisSecretKeysPoor, genesisSecretKeysRich) import Pos.Core.Block (mainBlockTxPayload) import Pos.Core.Txp (TxAux, mkTxPayload) import Pos.Crypto (SecretKey, toPublic) @@ -44,6 +43,8 @@ import Test.Pos.Block.Logic.Util (EnableTxPayload (..), import Test.Pos.Block.Property (blockPropertySpec) import Test.Pos.Configuration (defaultTestBlockVersionData, withStaticConfigurations) +import Test.Pos.Core.Dummy (dummyEpochSlots, dummyK, + dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck (maybeStopProperty, stopProperty) @@ -120,16 +121,14 @@ genGenesisInitializer = do lrcCorrectnessProp :: HasConfigurations => BlockProperty () lrcCorrectnessProp = do - let k = blkSecurityParam -- This value is how many blocks we need to generate first. We -- want to generate blocks for all slots which will be considered -- in LRC except the last one, because we want to include some -- special transactions into it. We don't use 'crucialSlot' or -- anything similar, because we don't want to rely on the code, -- but rather want to use our knowledge. - let blkCount0 = 8 * k - 1 - () <$ bpGenBlocks dummyProtocolMagic - (Just blkCount0) + let blkCount0 = 8 * dummyK - 1 + () <$ bpGenBlocks (Just blkCount0) (EnableTxPayload False) (InplaceDB True) genAndApplyBlockFixedTxs =<< txsBeforeBoundary @@ -143,12 +142,11 @@ lrcCorrectnessProp = do -- We need to have at least 'k' blocks after the boundary to make -- sure that stable blocks are indeed stable. Note that we have -- already applied 1 blocks, hence 'pred'. - blkCount1 <- pred <$> pick (choose (k, 2 * k)) - () <$ bpGenBlocks dummyProtocolMagic - (Just blkCount1) + blkCount1 <- pred <$> pick (choose (dummyK, 2 * dummyK)) + () <$ bpGenBlocks (Just blkCount1) (EnableTxPayload False) (InplaceDB True) - lift $ Lrc.lrcSingleShot dummyProtocolMagic 1 + lift $ Lrc.lrcSingleShot dummyProtocolMagic dummyProtocolConstants 1 leaders1 <- maybeStopProperty "No leaders for epoch#1!" =<< lift (Lrc.getLeadersForEpoch 1) -- Here we use 'genesisSeed' (which is the seed for the 0-th @@ -160,7 +158,7 @@ lrcCorrectnessProp = do -- DB iteration. let sortedStakes = sortOn (serialize' . fst) (HM.toList stableStakes) let expectedLeadersStakes = - Lrc.followTheSatoshi epochSlots genesisSeed sortedStakes + Lrc.followTheSatoshi dummyEpochSlots genesisSeed sortedStakes when (expectedLeadersStakes /= leaders1) $ stopProperty $ sformat ("expectedLeadersStakes /= leaders1\n"% "Stakes version: "%listJson% @@ -240,11 +238,10 @@ checkRichmen = do genAndApplyBlockFixedTxs :: HasConfigurations => [TxAux] -> BlockProperty () genAndApplyBlockFixedTxs txs = do let txPayload = mkTxPayload txs - emptyBlund <- bpGenBlock dummyProtocolMagic - (EnableTxPayload False) - (InplaceDB False) + emptyBlund <- bpGenBlock (EnableTxPayload False) (InplaceDB False) let blund = emptyBlund & _1 . _Right . mainBlockTxPayload .~ txPayload lift $ applyBlocksUnsafe dummyProtocolMagic + dummyProtocolConstants (ShouldCallBListener False) (one blund) Nothing @@ -271,33 +268,32 @@ txsAfterBoundary = pure [] -- Less than `k` blocks test. ---------------------------------------------------------------------------- -lessThanKAfterCrucialProp - :: HasConfigurations => BlockProperty () +lessThanKAfterCrucialProp :: HasConfigurations => BlockProperty () lessThanKAfterCrucialProp = do - let k = blkSecurityParam -- We need to generate '8 * k' blocks for first '8 * k' slots. - let inFirst8K = 8 * k + let inFirst8K = 8 * dummyK -- And then we need to generate random number of blocks in range -- '[0 .. 2 * k]'. - inLast2K <- pick (choose (0, 2 * k)) - let toGenerate = inFirst8K + inLast2K + inLast2K <- pick (choose (0, 2 * dummyK)) + let toGenerate = inFirst8K + inLast2K -- LRC should succeed iff number of blocks in last '2 * k' slots is -- at least 'k'. - let shouldSucceed = inLast2K >= k - () <$ bpGenBlocks dummyProtocolMagic - (Just toGenerate) - (EnableTxPayload False) - (InplaceDB True) + let shouldSucceed = inLast2K >= dummyK + () <$ bpGenBlocks (Just toGenerate) (EnableTxPayload False) (InplaceDB True) let mkFormat expectedOutcome = - ("We expected LRC to " %expectedOutcome % " because there are " %int % - " blocks after crucial slot, but it failed") - let unexpectedFailMsg = sformat (mkFormat "succeed") inLast2K + ( "We expected LRC to " + % expectedOutcome + % " because there are " + % int + % " blocks after crucial slot, but it failed" + ) + let unexpectedFailMsg = sformat (mkFormat "succeed") inLast2K let unexpectedSuccessMsg = sformat (mkFormat "fail") inLast2K - lift (try $ Lrc.lrcSingleShot dummyProtocolMagic 1) >>= \case - Left Lrc.UnknownBlocksForLrc - | shouldSucceed -> stopProperty unexpectedFailMsg - | otherwise -> pass - Left e -> lift (throwM e) - Right () - | shouldSucceed -> pass - | otherwise -> stopProperty unexpectedSuccessMsg + lift (try $ Lrc.lrcSingleShot dummyProtocolMagic dummyProtocolConstants 1) + >>= \case + Left Lrc.UnknownBlocksForLrc + | shouldSucceed -> stopProperty unexpectedFailMsg + | otherwise -> pass + Left e -> lift (throwM e) + Right () | shouldSucceed -> pass + | otherwise -> stopProperty unexpectedSuccessMsg diff --git a/infra/Pos/Infra/DHT/Workers.hs b/infra/Pos/Infra/DHT/Workers.hs index 99e9ec9e0b4..483b7eda3ef 100644 --- a/infra/Pos/Infra/DHT/Workers.hs +++ b/infra/Pos/Infra/DHT/Workers.hs @@ -14,7 +14,7 @@ import Network.Kademlia (takeSnapshot) import System.Wlog (WithLogger, logNotice) import Pos.Binary.Class (serialize) -import Pos.Core (HasProtocolConstants) +import Pos.Core (BlockCount, kEpochSlots) import Pos.Core.Slotting (flattenSlotId, slotIdF) import Pos.Infra.Binary.DHTModel () import Pos.Infra.DHT.Constants (kademliaDumpInterval) @@ -40,29 +40,36 @@ type DhtWorkMode ctx m = ) dhtWorkers - :: ( DhtWorkMode ctx m - , HasProtocolConstants - ) - => KademliaDHTInstance -> [Diffusion m -> m ()] -dhtWorkers kademliaInst@KademliaDHTInstance {..} = - [ dumpKademliaStateWorker kademliaInst ] + :: DhtWorkMode ctx m + => BlockCount + -> KademliaDHTInstance + -> [Diffusion m -> m ()] +dhtWorkers k kademliaInst@KademliaDHTInstance {..} = + [ dumpKademliaStateWorker k kademliaInst ] dumpKademliaStateWorker - :: ( DhtWorkMode ctx m - , HasProtocolConstants - ) - => KademliaDHTInstance + :: DhtWorkMode ctx m + => BlockCount + -> KademliaDHTInstance -> Diffusion m -> m () -dumpKademliaStateWorker kademliaInst = \_ -> onNewSlot onsp $ \slotId -> - when (isTimeToDump slotId) $ recoveryCommGuard "dump kademlia state" $ do - let dumpFile = kdiDumpPath kademliaInst - logNotice $ sformat ("Dumping kademlia snapshot on slot: "%slotIdF) slotId - let inst = kdiHandle kademliaInst - snapshot <- liftIO $ takeSnapshot inst - case dumpFile of - Just fp -> liftIO . BSL.writeFile fp . serialize $ snapshot - Nothing -> return () +dumpKademliaStateWorker k kademliaInst _ = + onNewSlot epochSlots onsp $ \slotId -> + when (isTimeToDump slotId) + $ recoveryCommGuard k "dump kademlia state" + $ do + let dumpFile = kdiDumpPath kademliaInst + logNotice $ sformat + ("Dumping kademlia snapshot on slot: " % slotIdF) + slotId + let inst = kdiHandle kademliaInst + snapshot <- liftIO $ takeSnapshot inst + case dumpFile of + Just fp -> + liftIO . BSL.writeFile fp . serialize $ snapshot + Nothing -> return () where - onsp = defaultOnNewSlotParams - isTimeToDump slotId = flattenSlotId slotId `mod` kademliaDumpInterval == 0 + epochSlots = kEpochSlots k + onsp = defaultOnNewSlotParams + isTimeToDump slotId = + flattenSlotId epochSlots slotId `mod` kademliaDumpInterval == 0 diff --git a/infra/Pos/Infra/Recovery/Info.hs b/infra/Pos/Infra/Recovery/Info.hs index 3a6d0cc1b04..95444e9aafa 100644 --- a/infra/Pos/Infra/Recovery/Info.hs +++ b/infra/Pos/Infra/Recovery/Info.hs @@ -5,7 +5,6 @@ module Pos.Infra.Recovery.Info ( SyncStatus (..) , MonadRecoveryInfo(..) , recoveryInProgress - , getSyncStatusK , recoveryCommGuard , needTriggerRecovery ) where @@ -16,8 +15,8 @@ import qualified Data.Text.Buildable import Formatting (bprint, build, sformat, stext, (%)) import System.Wlog (WithLogger, logDebug) -import Pos.Core (HasProtocolConstants, SlotCount, SlotId, slotIdF, - slotSecurityParam) +import Pos.Core (BlockCount, SlotCount, SlotId, kEpochSlots, + kSlotSecurityParam, slotIdF) -- | An algebraic data type which represents how well we are -- synchronized with the network. @@ -63,40 +62,28 @@ instance Buildable SyncStatus where SSKindaSynced -> "we are moderately synchronized" class Monad m => MonadRecoveryInfo m where - -- | Returns our sycnrhonization status. The argument determines + -- | Returns our synchronization status. The argument determines -- how much we should lag behind for 'SSLagBehind' status to take -- place. See 'SyncStatus' for details. -- Implementation must check conditions in the same order as they -- are enumerated in 'SyncStatus'. - getSyncStatus :: SlotCount -> m SyncStatus + getSyncStatus :: SlotCount -> SlotCount -> m SyncStatus -- | Returns if our 'SyncStatus' is 'SSDoingRecovery' (which is -- equivalent to “we're doing recovery”). -recoveryInProgress :: MonadRecoveryInfo m => m Bool -recoveryInProgress = - getSyncStatus 0 {- 0 doesn't matter -} <&> \case +recoveryInProgress :: MonadRecoveryInfo m => SlotCount -> m Bool +recoveryInProgress epochSlots = + getSyncStatus epochSlots 0 {- 0 doesn't matter -} <&> \case SSDoingRecovery -> True _ -> False --- | Get sync status using K as lagBehind param. -getSyncStatusK :: (MonadRecoveryInfo m, HasProtocolConstants) => m SyncStatus -getSyncStatusK = getSyncStatus lagBehindParam - where - -- It's actually questionable which value to use here. The less it - -- is, the stricter is the condition to do some - -- work. 'slotSecurityParam' is reasonable, but maybe we should use - -- something smaller. - lagBehindParam :: SlotCount - lagBehindParam = slotSecurityParam - -- | This is a helper function which runs given action only if we are -- kinda synchronized with the network. It is useful for workers -- which shouldn't do anything while we are not synchronized. recoveryCommGuard - :: (MonadRecoveryInfo m, WithLogger m, HasProtocolConstants) - => Text -> m () -> m () -recoveryCommGuard actionName action = - getSyncStatusK >>= \case + :: (MonadRecoveryInfo m, WithLogger m) => BlockCount -> Text -> m () -> m () +recoveryCommGuard k actionName action = + getSyncStatus (kEpochSlots k) (kSlotSecurityParam k) >>= \case SSKindaSynced -> action status -> logDebug $ diff --git a/infra/Pos/Infra/Slotting/Class.hs b/infra/Pos/Infra/Slotting/Class.hs index 9fdb8130131..8fd9c3dcb17 100644 --- a/infra/Pos/Infra/Slotting/Class.hs +++ b/infra/Pos/Infra/Slotting/Class.hs @@ -10,25 +10,25 @@ import Universum import Control.Monad.Trans (MonadTrans) -import Pos.Core.Slotting (SlotId (..), Timestamp) +import Pos.Core.Slotting (SlotCount, SlotId (..), Timestamp) import Pos.Infra.Slotting.MemState (MonadSlotsData) -- | Type class providing information about current slot. class (MonadSlotsData ctx m) => MonadSlots ctx m where - getCurrentSlot :: m (Maybe SlotId) + getCurrentSlot :: SlotCount -> m (Maybe SlotId) -- | Blocking version of 'getCurrentSlot'. This function doesn't -- return until current slot is known. - getCurrentSlotBlocking :: m SlotId + getCurrentSlotBlocking :: SlotCount -> m SlotId -- | This function tries to predict current slot as accurately as it can. -- If 'getCurrentTime' returns unreliable time, -- then function returns last known slot -- If our slotting data into DB is outdated, -- then function tries to extrapolate slot using last know slotting data - getCurrentSlotInaccurate :: m SlotId + getCurrentSlotInaccurate :: SlotCount -> m SlotId currentTimeSlotting :: m Timestamp @@ -37,7 +37,7 @@ instance {-# OVERLAPPABLE #-} (MonadSlots ctx m, MonadTrans t, MonadReader ctx (t m), MonadIO (t m)) => MonadSlots ctx (t m) where - getCurrentSlot = lift getCurrentSlot - getCurrentSlotBlocking = lift getCurrentSlotBlocking + getCurrentSlot = lift . getCurrentSlot + getCurrentSlotBlocking = lift . getCurrentSlotBlocking currentTimeSlotting = lift currentTimeSlotting - getCurrentSlotInaccurate = lift getCurrentSlotInaccurate + getCurrentSlotInaccurate = lift . getCurrentSlotInaccurate diff --git a/infra/Pos/Infra/Slotting/Impl/Simple.hs b/infra/Pos/Infra/Slotting/Impl/Simple.hs index 1f1b96a9465..b260455130a 100644 --- a/infra/Pos/Infra/Slotting/Impl/Simple.hs +++ b/infra/Pos/Infra/Slotting/Impl/Simple.hs @@ -21,8 +21,7 @@ import Universum import Mockable (CurrentTime, Mockable, currentTime) -import Pos.Core.Configuration (HasProtocolConstants) -import Pos.Core.Slotting (SlotId (..), Timestamp (..), +import Pos.Core.Slotting (SlotCount, SlotId (..), Timestamp (..), unflattenSlotId) import Pos.Infra.Slotting.Impl.Util (approxSlotUsingOutdated, slotFromTimestamp) @@ -56,64 +55,67 @@ data SimpleSlottingState = SimpleSlottingState type SimpleSlottingStateVar = TVar SimpleSlottingState -mkSimpleSlottingStateVar :: (MonadIO m, HasProtocolConstants) => m SimpleSlottingStateVar -mkSimpleSlottingStateVar = atomically $ newTVar $ SimpleSlottingState $ unflattenSlotId 0 +mkSimpleSlottingStateVar :: MonadIO m => SlotCount -> m SimpleSlottingStateVar +mkSimpleSlottingStateVar epochSlots = + atomically $ newTVar $ SimpleSlottingState $ unflattenSlotId epochSlots 0 ---------------------------------------------------------------------------- -- Implementation ---------------------------------------------------------------------------- getCurrentSlotSimple' - :: (SimpleSlottingMode ctx m, HasProtocolConstants) - => SimpleSlottingStateVar + :: SimpleSlottingMode ctx m + => SlotCount + -> SimpleSlottingStateVar -> m (Maybe SlotId) -getCurrentSlotSimple' var = +getCurrentSlotSimple' epochSlots var = currentTimeSlottingSimple - >>= slotFromTimestamp + >>= slotFromTimestamp epochSlots >>= traverse (updateLastSlot var) getCurrentSlotSimple - :: (MonadSimpleSlotting ctx m, HasProtocolConstants) - => m (Maybe SlotId) -getCurrentSlotSimple = view (lensOf @SimpleSlottingStateVar) >>= getCurrentSlotSimple' + :: MonadSimpleSlotting ctx m => SlotCount -> m (Maybe SlotId) +getCurrentSlotSimple epochSlots = + view (lensOf @SimpleSlottingStateVar) >>= getCurrentSlotSimple' epochSlots getCurrentSlotBlockingSimple' - :: (SimpleSlottingMode ctx m, HasProtocolConstants) - => SimpleSlottingStateVar + :: SimpleSlottingMode ctx m + => SlotCount + -> SimpleSlottingStateVar -> m SlotId -getCurrentSlotBlockingSimple' var = do +getCurrentSlotBlockingSimple' epochSlots var = do (_, nextEpochIndex) <- getCurrentNextEpochIndexM - getCurrentSlotSimple' var >>= \case + getCurrentSlotSimple' epochSlots var >>= \case Just slot -> pure slot - Nothing -> do + Nothing -> do waitCurrentEpochEqualsM nextEpochIndex - getCurrentSlotBlockingSimple' var + getCurrentSlotBlockingSimple' epochSlots var getCurrentSlotBlockingSimple - :: (MonadSimpleSlotting ctx m, HasProtocolConstants) - => m SlotId -getCurrentSlotBlockingSimple = - view (lensOf @SimpleSlottingStateVar) >>= getCurrentSlotBlockingSimple' + :: MonadSimpleSlotting ctx m => SlotCount -> m SlotId +getCurrentSlotBlockingSimple epochSlots = view (lensOf @SimpleSlottingStateVar) + >>= getCurrentSlotBlockingSimple' epochSlots getCurrentSlotInaccurateSimple' - :: (SimpleSlottingMode ctx m, HasProtocolConstants) - => SimpleSlottingStateVar + :: SimpleSlottingMode ctx m + => SlotCount + -> SimpleSlottingStateVar -> m SlotId -getCurrentSlotInaccurateSimple' var = - getCurrentSlotSimple' var >>= \case +getCurrentSlotInaccurateSimple' epochSlots var = + getCurrentSlotSimple' epochSlots var >>= \case Just slot -> pure slot Nothing -> do lastSlot <- _sssLastSlot <$> atomically (readTVar var) max lastSlot <$> (currentTimeSlottingSimple >>= - approxSlotUsingOutdated) + approxSlotUsingOutdated epochSlots) getCurrentSlotInaccurateSimple - :: (MonadSimpleSlotting ctx m, HasProtocolConstants) - => m SlotId -getCurrentSlotInaccurateSimple = - view (lensOf @SimpleSlottingStateVar) >>= getCurrentSlotInaccurateSimple' + :: MonadSimpleSlotting ctx m => SlotCount -> m SlotId +getCurrentSlotInaccurateSimple epochSlots = + view (lensOf @SimpleSlottingStateVar) + >>= getCurrentSlotInaccurateSimple' epochSlots -currentTimeSlottingSimple :: (SimpleSlottingMode ctx m) => m Timestamp +currentTimeSlottingSimple :: SimpleSlottingMode ctx m => m Timestamp currentTimeSlottingSimple = Timestamp <$> currentTime updateLastSlot :: MonadIO m => SimpleSlottingStateVar -> SlotId -> m SlotId diff --git a/infra/Pos/Infra/Slotting/Impl/Util.hs b/infra/Pos/Infra/Slotting/Impl/Util.hs index 6105b852b87..be9fae3bab8 100644 --- a/infra/Pos/Infra/Slotting/Impl/Util.hs +++ b/infra/Pos/Infra/Slotting/Impl/Util.hs @@ -9,9 +9,9 @@ import Universum import Data.Time.Units (Microsecond, convertUnit) -import Pos.Core.Configuration (HasProtocolConstants, epochSlots) -import Pos.Core.Slotting (EpochIndex, LocalSlotIndex, SlotId (..), - Timestamp (..), addTimeDiffToTimestamp, flattenEpochIndex, +import Pos.Core.Slotting (EpochIndex, LocalSlotIndex, SlotCount, + SlotId (..), Timestamp (..), addTimeDiffToTimestamp, + flattenEpochIndex, localSlotIndexMinBound, mkLocalSlotIndex, unflattenSlotId) import Pos.Util.Util (leftToPanic) @@ -23,10 +23,11 @@ import Pos.Infra.Slotting.Types (EpochSlottingData (..), SlottingData, -- | Approximate current slot using outdated slotting data. approxSlotUsingOutdated - :: (MonadSlotsData ctx m, HasProtocolConstants) - => Timestamp + :: MonadSlotsData ctx m + => SlotCount + -> Timestamp -> m SlotId -approxSlotUsingOutdated t = do +approxSlotUsingOutdated epochSlots t = do -- This is a constant and doesn't need to be fetched atomically systemStart <- getSystemStartM @@ -36,15 +37,15 @@ approxSlotUsingOutdated t = do let epochStart = esdStartDiff nextSlottingData `addTimeDiffToTimestamp` systemStart pure $ - if | t < epochStart -> SlotId (currentEpochIndex + 1) minBound + if | t < epochStart -> SlotId (currentEpochIndex + 1) localSlotIndexMinBound | otherwise -> outdatedEpoch systemStart t (currentEpochIndex + 1) nextSlottingData where outdatedEpoch systemStart (Timestamp curTime) epoch EpochSlottingData {..} = let duration = convertUnit esdSlotDuration start = getTimestamp (esdStartDiff `addTimeDiffToTimestamp` systemStart) in - unflattenSlotId $ - flattenEpochIndex epoch + fromIntegral ((curTime - start) `div` duration) + unflattenSlotId epochSlots $ + flattenEpochIndex epochSlots epoch + fromIntegral ((curTime - start) `div` duration) -- | Get both values we need in a single fetch, so we don't end up with -- invalid data. @@ -59,10 +60,11 @@ approxSlotUsingOutdated t = do -- | Compute current slot from current timestamp based on data -- provided by 'MonadSlotsData'. slotFromTimestamp - :: (MonadSlotsData ctx m, HasProtocolConstants) - => Timestamp + :: MonadSlotsData ctx m + => SlotCount + -> Timestamp -> m (Maybe SlotId) -slotFromTimestamp approxCurTime = do +slotFromTimestamp epochSlots approxCurTime = do systemStart <- getSystemStartM withSlottingVarAtomM (iterateBackwardsSearch systemStart) where @@ -136,7 +138,7 @@ slotFromTimestamp approxCurTime = do localSlot :: LocalSlotIndex localSlot = leftToPanic "computeSlotUsingEpoch: " $ - mkLocalSlotIndex localSlotNumeric + mkLocalSlotIndex epochSlots localSlotNumeric slotDuration :: Microsecond slotDuration = convertUnit esdSlotDuration diff --git a/infra/Pos/Infra/Slotting/Util.hs b/infra/Pos/Infra/Slotting/Util.hs index 663c547d0a6..6a084bb0daf 100644 --- a/infra/Pos/Infra/Slotting/Util.hs +++ b/infra/Pos/Infra/Slotting/Util.hs @@ -32,8 +32,8 @@ import Mockable (Async, Delay, Mockable, delay, timeout) import System.Wlog (WithLogger, logDebug, logInfo, logNotice, logWarning, modifyLoggerName) -import Pos.Core (FlatSlotId, HasProtocolConstants, LocalSlotIndex, - SlotId (..), Timestamp (..), flattenSlotId, slotIdF) +import Pos.Core (FlatSlotId, LocalSlotIndex, SlotCount, SlotId (..), + Timestamp (..), flattenSlotId, slotIdF, slotIdSucc) import Pos.Infra.Recovery.Info (MonadRecoveryInfo, recoveryInProgress) import Pos.Infra.Reporting.Methods (MonadReporting, reportOrLogE) import Pos.Infra.Shutdown (HasShutdownContext) @@ -49,8 +49,9 @@ import Pos.Util.Util (maybeThrow) -- | Get flat id of current slot based on MonadSlots. -getCurrentSlotFlat :: (MonadSlots ctx m, HasProtocolConstants) => m (Maybe FlatSlotId) -getCurrentSlotFlat = fmap flattenSlotId <$> getCurrentSlot +getCurrentSlotFlat :: MonadSlots ctx m => SlotCount -> m (Maybe FlatSlotId) +getCurrentSlotFlat epochSlots = + fmap (flattenSlotId epochSlots) <$> getCurrentSlot epochSlots -- | Get timestamp when given slot starts. getSlotStart :: MonadSlotsData ctx m => SlotId -> m (Maybe Timestamp) @@ -157,23 +158,34 @@ data ActionTerminationPolicy -- it. This function uses Mockable and assumes consistency between -- MonadSlots and Mockable implementations. onNewSlot - :: (MonadOnNewSlot ctx m, HasProtocolConstants) - => OnNewSlotParams -> (SlotId -> m ()) -> m () -onNewSlot = onNewSlotImpl False + :: MonadOnNewSlot ctx m + => SlotCount + -> OnNewSlotParams + -> (SlotId -> m ()) + -> m () +onNewSlot epochSlots = onNewSlotImpl epochSlots False onNewSlotWithLogging - :: (MonadOnNewSlot ctx m, HasProtocolConstants) - => OnNewSlotParams -> (SlotId -> m ()) -> m () -onNewSlotWithLogging = onNewSlotImpl True + :: MonadOnNewSlot ctx m + => SlotCount + -> OnNewSlotParams + -> (SlotId -> m ()) + -> m () +onNewSlotWithLogging epochSlots = onNewSlotImpl epochSlots True -- TODO [CSL-198]: think about exceptions more carefully. onNewSlotImpl - :: forall ctx m. (MonadOnNewSlot ctx m, HasProtocolConstants) - => Bool -> OnNewSlotParams -> (SlotId -> m ()) -> m () -onNewSlotImpl withLogging params action = + :: forall ctx m + . MonadOnNewSlot ctx m + => SlotCount + -> Bool + -> OnNewSlotParams + -> (SlotId -> m ()) + -> m () +onNewSlotImpl epochSlots withLogging params action = impl `catch` workerHandler where - impl = onNewSlotDo withLogging Nothing params actionWithCatch + impl = onNewSlotDo epochSlots withLogging Nothing params actionWithCatch -- [CSL-198] TODO: consider removing it. actionWithCatch s = action s `catch` actionHandler actionHandler :: SomeException -> m () @@ -184,15 +196,20 @@ onNewSlotImpl withLogging params action = -- REPORT:ERROR 'reportOrLogE' in 'onNewSlotImpl' reportOrLogE "Error occurred in 'onNewSlot' worker itself: " e delay =<< getNextEpochSlotDuration - onNewSlotImpl withLogging params action + onNewSlotImpl epochSlots withLogging params action onNewSlotDo - :: (MonadOnNewSlot ctx m, HasProtocolConstants) - => Bool -> Maybe SlotId -> OnNewSlotParams -> (SlotId -> m ()) -> m () -onNewSlotDo withLogging expectedSlotId onsp action = do + :: MonadOnNewSlot ctx m + => SlotCount + -> Bool + -> Maybe SlotId + -> OnNewSlotParams + -> (SlotId -> m ()) + -> m () +onNewSlotDo epochSlots withLogging expectedSlotId onsp action = do curSlot <- waitUntilExpectedSlot - let nextSlot = succ curSlot + let nextSlot = slotIdSucc epochSlots curSlot Timestamp curTime <- currentTimeSlotting Timestamp nextSlotStart <- getSlotStartEmpatically nextSlot let timeToWait = nextSlotStart - curTime @@ -211,7 +228,7 @@ onNewSlotDo withLogging expectedSlotId onsp action = do when withLogging $ logTTW timeToWait delay timeToWait let newParams = onsp { onspStartImmediately = True } - onNewSlotDo withLogging (Just nextSlot) newParams action + onNewSlotDo epochSlots withLogging (Just nextSlot) newParams action where waitUntilExpectedSlot = do -- onNewSlotWorker doesn't make sense in recovery phase. Most @@ -219,8 +236,8 @@ onNewSlotDo withLogging expectedSlotId onsp action = do -- (same epoch), the only priority is to sync with the -- chain. So we're skipping and checking again. let skipRound = delay recoveryRefreshDelay >> waitUntilExpectedSlot - ifM recoveryInProgress skipRound $ do - slot <- getCurrentSlotBlocking + ifM (recoveryInProgress epochSlots) skipRound $ do + slot <- getCurrentSlotBlocking epochSlots if | maybe (const True) (<=) expectedSlotId slot -> return slot -- Here we wait for short intervals to be sure that expected slot -- has really started, taking into account possible inaccuracies. @@ -233,9 +250,9 @@ onNewSlotDo withLogging expectedSlotId onsp action = do logTTW timeToWait = modifyLoggerName (<> "slotting") $ logDebug $ sformat ("Waiting for "%shown%" before new slot") timeToWait -logNewSlotWorker :: (MonadOnNewSlot ctx m, HasProtocolConstants) => m () -logNewSlotWorker = - onNewSlotWithLogging defaultOnNewSlotParams $ \slotId -> do +logNewSlotWorker :: MonadOnNewSlot ctx m => SlotCount -> m () +logNewSlotWorker epochSlots = + onNewSlotWithLogging epochSlots defaultOnNewSlotParams $ \slotId -> do modifyLoggerName (<> "slotting") $ logNotice $ sformat ("New slot has just started: " %slotIdF) slotId diff --git a/infra/Pos/Infra/Util/JsonLog/Events.hs b/infra/Pos/Infra/Util/JsonLog/Events.hs index 17a312504b0..faa1d88bdab 100644 --- a/infra/Pos/Infra/Util/JsonLog/Events.hs +++ b/infra/Pos/Infra/Util/JsonLog/Events.hs @@ -39,9 +39,9 @@ import Mockable (realTime) import Serokell.Aeson.Options (defaultOptions) import System.Wlog (WithLogger) -import Pos.Core (EpochIndex (..), HasConfiguration, HeaderHash, - SlotId (..), gbHeader, gbhPrevBlock, getSlotIndex, - headerHash, headerHashF, mkLocalSlotIndex) +import Pos.Core (EpochIndex (..), HeaderHash, SlotCount, SlotId (..), + gbHeader, gbhPrevBlock, getSlotIndex, headerHash, + headerHashF, mkLocalSlotIndex) import Pos.Core.Block (Block, mainBlockTxPayload) import Pos.Core.Block.Genesis (genBlockEpoch) import Pos.Core.Block.Main (mainBlockSlot) @@ -127,30 +127,32 @@ $(deriveJSON defaultOptions ''JLTxR) $(deriveJSON defaultOptions ''JLMemPool) -- | Get 'SlotId' from 'JLSlotId'. -fromJLSlotId :: (HasConfiguration, MonadError Text m) => JLSlotId -> m SlotId -fromJLSlotId (ep, sl) = SlotId (EpochIndex ep) <$> mkLocalSlotIndex sl +fromJLSlotId :: MonadError Text m => SlotCount -> JLSlotId -> m SlotId +fromJLSlotId epochSlots (ep, sl) = + SlotId (EpochIndex ep) <$> mkLocalSlotIndex epochSlots sl -- | Get 'SlotId' from 'JLSlotId'. -fromJLSlotIdUnsafe :: HasConfiguration => JLSlotId -> SlotId -fromJLSlotIdUnsafe x = case fromJLSlotId x of +fromJLSlotIdUnsafe :: SlotCount -> JLSlotId -> SlotId +fromJLSlotIdUnsafe epochSlots x = case fromJLSlotId epochSlots x of Right y -> y Left _ -> error "illegal slot id" -- | Return event of created block. -jlCreatedBlock :: HasConfiguration => Block -> JLEvent -jlCreatedBlock block = JLCreatedBlock $ JLBlock {..} - where - jlHash = showHeaderHash $ headerHash block - jlPrevBlock = showHeaderHash $ case block of +jlCreatedBlock :: SlotCount -> Block -> JLEvent +jlCreatedBlock epochSlots block = JLCreatedBlock $ JLBlock + { jlHash = showHeaderHash $ headerHash block + , jlPrevBlock = showHeaderHash $ case block of Left gB -> view gbhPrevBlock (gB ^. gbHeader) Right mB -> view gbhPrevBlock (mB ^. gbHeader) - jlSlot = (getEpochIndex $ siEpoch slot, getSlotIndex $ siSlot slot) - jlTxs = case block of - Left _ -> [] - Right mB -> map fromTx . toList $ mB ^. mainBlockTxPayload . txpTxs + , jlTxs = case block of + Left _ -> [] + Right mB -> map fromTx . toList $ mB ^. mainBlockTxPayload . txpTxs + , jlSlot = (getEpochIndex $ siEpoch slot, getSlotIndex $ siSlot slot) + } + where slot :: SlotId slot = case block of - Left gB -> let slotZero = case mkLocalSlotIndex 0 of + Left gB -> let slotZero = case mkLocalSlotIndex epochSlots 0 of Right sz -> sz Left _ -> error "impossible branch" in SlotId (gB ^. genBlockEpoch) slotZero diff --git a/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs b/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs index ac8ed06cb99..e7d24484a2b 100644 --- a/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs +++ b/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs @@ -303,7 +303,7 @@ runBenchmark = do streamIORef <- newIORef [] let seed = 0 size = 4 - !arbitraryBlock = force $ Right (generateMainBlock protocolMagic protocolConstants seed size) + !arbitraryBlock = force $ Right (generateMainBlock protocolMagic seed size) !arbitraryHashes = force $ someHash :| replicate 2199 someHash !arbitraryHeader = force $ Core.getBlockHeader arbitraryBlock !arbitraryHeaders = force $ arbitraryHeader :| replicate 2199 arbitraryHeader diff --git a/lib/src/Pos/DB/DB.hs b/lib/src/Pos/DB/DB.hs index aafbaab26da..954aabbe55c 100644 --- a/lib/src/Pos/DB/DB.hs +++ b/lib/src/Pos/DB/DB.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilies #-} - -- | Higher-level DB functionality. module Pos.DB.DB @@ -10,8 +7,8 @@ module Pos.DB.DB import Universum -import Pos.Core (BlockVersionData, GenesisHash (..), SlotCount, - genesisHash, headerHash) +import Pos.Core (BlockVersionData, GenesisHash (..), + ProtocolConstants, genesisHash, headerHash, pcEpochSlots) import Pos.Core.Block.Constructors (genesisBlock0) import Pos.Crypto (ProtocolMagic) import Pos.DB.Block (prepareBlockDB) @@ -23,17 +20,18 @@ import Pos.Update.DB (getAdoptedBVData) -- | Initialize DBs if necessary. initNodeDBs - :: forall ctx m. - ( MonadReader ctx m - , MonadDB m - ) - => ProtocolMagic -> SlotCount -> m () -initNodeDBs pm epochSlots = do + :: forall ctx m + . (MonadReader ctx m, MonadDB m) + => ProtocolMagic + -> ProtocolConstants + -> m () +initNodeDBs pm pc = do let initialTip = headerHash gb prepareBlockDB gb - prepareGStateDB initialTip + prepareGStateDB pc initialTip prepareLrcDB epochSlots where + epochSlots = pcEpochSlots pc gb = genesisBlock0 pm (GenesisHash genesisHash) (genesisLeaders epochSlots) ---------------------------------------------------------------------------- diff --git a/lib/src/Pos/GState/GState.hs b/lib/src/Pos/GState/GState.hs index fedb2b2a48c..9325c9710ed 100644 --- a/lib/src/Pos/GState/GState.hs +++ b/lib/src/Pos/GState/GState.hs @@ -6,7 +6,8 @@ module Pos.GState.GState import Universum -import Pos.Core (GenesisData (..), HeaderHash, genesisData) +import Pos.Core (GenesisData (..), HeaderHash, ProtocolConstants, + genesisData) import Pos.DB.Class (MonadDB) import Pos.DB.GState.Common (initGStateCommon, isInitialized, setInitialized) @@ -23,14 +24,15 @@ prepareGStateDB :: ( MonadReader ctx m , MonadDB m ) - => HeaderHash + => ProtocolConstants + -> HeaderHash -> m () -prepareGStateDB initialTip = unlessM isInitialized $ do +prepareGStateDB pc initialTip = unlessM isInitialized $ do initGStateCommon initialTip initGStateUtxo genesisUtxo initSscDB initGStateStakes genesisUtxo - initGStateUS + initGStateUS pc initGStateDlg $ gdHeavyDelegation genesisData initGStateBlockExtra initialTip diff --git a/lib/src/Pos/Launcher/Configuration.hs b/lib/src/Pos/Launcher/Configuration.hs index c7b940919b8..cbd12aeba42 100644 --- a/lib/src/Pos/Launcher/Configuration.hs +++ b/lib/src/Pos/Launcher/Configuration.hs @@ -35,7 +35,7 @@ import System.Wlog (WithLogger, logInfo) -- FIXME consistency on the locus of the JSON instances for configuration. -- Core keeps them separate, infra update and ssc define them on-site. import Pos.Aeson.Core.Configuration () -import Pos.Core (Address, decodeTextAddress) +import Pos.Core (Address, ProtocolConstants, decodeTextAddress) import Pos.Core.Slotting (Timestamp (..)) import Pos.Util.Config (parseYamlConfig) @@ -115,7 +115,12 @@ withConfigurations :: (WithLogger m, MonadThrow m, MonadIO m) => Maybe AssetLockPath -> ConfigurationOptions - -> (HasConfigurations => NtpConfiguration -> ProtocolMagic -> m r) + -> ( HasConfigurations + => NtpConfiguration + -> ProtocolMagic + -> ProtocolConstants + -> m r + ) -> m r withConfigurations mAssetLockPath cfo act = do logInfo ("using configurations: " <> show cfo) diff --git a/lib/src/Pos/Launcher/Launcher.hs b/lib/src/Pos/Launcher/Launcher.hs index 5a7a7b62c40..8ccc96f0184 100644 --- a/lib/src/Pos/Launcher/Launcher.hs +++ b/lib/src/Pos/Launcher/Launcher.hs @@ -14,7 +14,7 @@ import Universum -- Get rid of production and use a 'Trace IO' instead. import Mockable.Production (Production (..)) -import Pos.Core.Configuration (epochSlots) +import Pos.Core (ProtocolConstants, pcBlkSecurityParam) import Pos.Crypto (ProtocolMagic) import Pos.DB.DB (initNodeDBs) import Pos.Infra.Diffusion.Types (Diffusion) @@ -35,16 +35,23 @@ import Pos.WorkMode (EmptyMempoolExt, RealMode) -- | Run full node in real mode. runNodeReal - :: ( HasConfigurations - , HasCompileInfo - ) + :: (HasConfigurations, HasCompileInfo) => ProtocolMagic + -> ProtocolConstants -> NodeParams -> SscParams - -> [Diffusion (RealMode EmptyMempoolExt) -> RealMode EmptyMempoolExt ()] + -> [ Diffusion (RealMode EmptyMempoolExt) + -> RealMode EmptyMempoolExt () + ] -> IO () -runNodeReal pm np sscnp plugins = runProduction $ - bracketNodeResources np sscnp (txpGlobalSettings pm) (initNodeDBs pm epochSlots) (Production . action) +runNodeReal pm pc np sscnp plugins = runProduction $ bracketNodeResources + (pcBlkSecurityParam pc) + np + sscnp + (txpGlobalSettings pm) + (initNodeDBs pm pc) + (Production . action) where action :: NodeResources EmptyMempoolExt -> IO () - action nr@NodeResources {..} = runRealMode pm nr (runNode pm nr plugins) + action nr@NodeResources {..} = + runRealMode pm pc nr (runNode pm pc nr plugins) diff --git a/lib/src/Pos/Launcher/Mode.hs b/lib/src/Pos/Launcher/Mode.hs index c8a4c3c7f33..a4a579a329e 100644 --- a/lib/src/Pos/Launcher/Mode.hs +++ b/lib/src/Pos/Launcher/Mode.hs @@ -87,9 +87,7 @@ instance HasConfiguration => MonadDB InitMode where dbDelete = dbDeleteDefault dbPutSerBlunds = dbPutSerBlundsRealDefault -instance (HasConfiguration, MonadSlotsData ctx InitMode) => - MonadSlots ctx InitMode - where +instance MonadSlotsData ctx InitMode => MonadSlots ctx InitMode where getCurrentSlot = getCurrentSlotSimple getCurrentSlotBlocking = getCurrentSlotBlockingSimple getCurrentSlotInaccurate = getCurrentSlotInaccurateSimple diff --git a/lib/src/Pos/Launcher/Resource.hs b/lib/src/Pos/Launcher/Resource.hs index a97ea895f63..aa6fc7b3fad 100644 --- a/lib/src/Pos/Launcher/Resource.hs +++ b/lib/src/Pos/Launcher/Resource.hs @@ -40,8 +40,8 @@ import Pos.Client.CLI.Util (readLoggerConfig) import Pos.Configuration import Pos.Context (ConnectedPeers (..), NodeContext (..), StartTime (..)) -import Pos.Core (HasConfiguration, Timestamp, gdStartTime, - genesisData) +import Pos.Core (BlockCount, HasConfiguration, Timestamp, gdStartTime, + genesisData, kEpochSlots) import Pos.DB (MonadDBRead, NodeDBs) import Pos.DB.Rocks (closeNodeDBs, openNodeDBs) import Pos.Delegation (DelegationVar, HasDlgConfiguration, @@ -96,19 +96,20 @@ data NodeResources ext = NodeResources -- | Allocate all resources used by node. They must be released eventually. allocateNodeResources - :: forall ext . - ( Default ext + :: forall ext + . ( Default ext , HasConfiguration , HasNodeConfiguration , HasDlgConfiguration , HasBlockConfiguration ) - => NodeParams + => BlockCount + -> NodeParams -> SscParams -> TxpGlobalSettings -> InitMode () -> Production (NodeResources ext) -allocateNodeResources np@NodeParams {..} sscnp txpSettings initDB = do +allocateNodeResources k np@NodeParams {..} sscnp txpSettings initDB = do logInfo "Allocating node resources..." npDbPath <- case npDbPathM of Nothing -> do @@ -147,12 +148,12 @@ allocateNodeResources np@NodeParams {..} sscnp txpSettings initDB = do , ancdEkgStore = nrEkgStore , ancdTxpMemState = txpVar } - ctx@NodeContext {..} <- allocateNodeContext ancd txpSettings nrEkgStore + ctx@NodeContext {..} <- allocateNodeContext k ancd txpSettings nrEkgStore putLrcContext ncLrcContext logDebug "Filled LRC Context future" dlgVar <- mkDelegationVar logDebug "Created DLG var" - sscState <- mkSscState + sscState <- mkSscState $ kEpochSlots k logDebug "Created SSC var" jsonLogHandle <- case npJLFile of @@ -193,23 +194,25 @@ releaseNodeResources NodeResources {..} = do -- | Run computation which requires 'NodeResources' ensuring that -- resources will be released eventually. -bracketNodeResources :: forall ext a. - ( Default ext - , HasConfiguration - , HasNodeConfiguration - , HasDlgConfiguration - , HasBlockConfiguration - ) - => NodeParams +bracketNodeResources + :: forall ext a + . ( Default ext + , HasConfiguration + , HasNodeConfiguration + , HasDlgConfiguration + , HasBlockConfiguration + ) + => BlockCount + -> NodeParams -> SscParams -> TxpGlobalSettings -> InitMode () -> (HasConfiguration => NodeResources ext -> Production a) -> Production a -bracketNodeResources np sp txp initDB action = do +bracketNodeResources k np sp txp initDB action = do let msg = "`NodeResources'" bracketWithLogging msg - (allocateNodeResources np sp txp initDB) + (allocateNodeResources k np sp txp initDB) releaseNodeResources $ \nodeRes ->do -- Notify systemd we are fully operative -- FIXME this is not the place to notify. @@ -256,13 +259,15 @@ data AllocateNodeContextData ext = AllocateNodeContextData } allocateNodeContext - :: forall ext . - (HasConfiguration, HasNodeConfiguration, HasBlockConfiguration) - => AllocateNodeContextData ext + :: forall ext + . (HasConfiguration, HasNodeConfiguration, HasBlockConfiguration) + => BlockCount + -> AllocateNodeContextData ext -> TxpGlobalSettings -> Metrics.Store -> InitMode NodeContext -allocateNodeContext ancd txpSettings ekgStore = do +allocateNodeContext k ancd txpSettings ekgStore = do + let epochSlots = kEpochSlots k let AllocateNodeContextData { ancdNodeParams = np@NodeParams {..} , ancdSscParams = sscnp , ancdPutSlotting = putSlotting @@ -281,7 +286,7 @@ allocateNodeContext ancd txpSettings ekgStore = do logDebug "Created LRC sync" ncSlottingVar <- (gdStartTime genesisData,) <$> mkSlottingVar logDebug "Created slotting variable" - ncSlottingContext <- mkSimpleSlottingStateVar + ncSlottingContext <- mkSimpleSlottingStateVar epochSlots logDebug "Created slotting context" putSlotting ncSlottingVar ncSlottingContext logDebug "Filled slotting future" @@ -294,11 +299,11 @@ allocateNodeContext ancd txpSettings ekgStore = do ncStartTime <- StartTime <$> liftIO Time.getCurrentTime ncLastKnownHeader <- newTVarIO Nothing logDebug "Created last known header and shutdown flag variables" - ncUpdateContext <- mkUpdateContext + ncUpdateContext <- mkUpdateContext epochSlots logDebug "Created context for update" ncSscContext <- createSscContext sscnp logDebug "Created context for ssc" - ncSlogContext <- mkSlogContext store + ncSlogContext <- mkSlogContext k store logDebug "Created context for slog" -- TODO synchronize the NodeContext peers var with whatever system -- populates it. diff --git a/lib/src/Pos/Launcher/Runner.hs b/lib/src/Pos/Launcher/Runner.hs index 1466ff40303..b450b70354d 100644 --- a/lib/src/Pos/Launcher/Runner.hs +++ b/lib/src/Pos/Launcher/Runner.hs @@ -30,9 +30,7 @@ import Pos.Block.Configuration (HasBlockConfiguration, import Pos.Configuration (HasNodeConfiguration, networkConnectionTimeout) import Pos.Context.Context (NodeContext (..)) -import Pos.Core (StakeholderId, addressHash) -import Pos.Core.Configuration (HasProtocolConstants, - protocolConstants) +import Pos.Core (ProtocolConstants, StakeholderId, addressHash) import Pos.Crypto (ProtocolMagic, toPublic) import Pos.Diffusion.Full (FullDiffusionConfiguration (..), diffusionLayerFull) @@ -78,11 +76,13 @@ runRealMode -- though they should use only @RealModeContext@ ) => ProtocolMagic + -> ProtocolConstants -> NodeResources ext -> (Diffusion (RealMode ext) -> RealMode ext a) -> IO a -runRealMode pm nr@NodeResources {..} act = runServer +runRealMode pm pc nr@NodeResources {..} act = runServer pm + pc ncNodeParams (EkgNodeMetrics nrEkgStore) ncShutdownContext @@ -90,12 +90,12 @@ runRealMode pm nr@NodeResources {..} act = runServer act' where NodeContext {..} = nrContext - NodeParams {..} = ncNodeParams - securityParams = bcSecurityParams npBehaviorConfig + NodeParams {..} = ncNodeParams + securityParams = bcSecurityParams npBehaviorConfig ourStakeholderId :: StakeholderId ourStakeholderId = addressHash (toPublic npSecretKey) logic :: Logic (RealMode ext) - logic = logicFull pm ourStakeholderId securityParams jsonLog + logic = logicFull pm pc ourStakeholderId securityParams jsonLog makeLogicIO :: Diffusion IO -> Logic IO makeLogicIO diffusion = hoistLogic (elimRealMode pm nr diffusion) logic act' :: Diffusion IO -> IO a @@ -145,20 +145,17 @@ elimRealMode pm NodeResources {..} diffusion action = runProduction $ do -- network connection timeout (nt-tcp), and, and the 'recoveryHeadersMessage' -- number. runServer - :: forall t . - ( HasProtocolConstants - , HasBlockConfiguration - , HasNodeConfiguration - , HasUpdateConfiguration - ) + :: forall t + . (HasBlockConfiguration, HasNodeConfiguration, HasUpdateConfiguration) => ProtocolMagic + -> ProtocolConstants -> NodeParams -> EkgNodeMetrics -> ShutdownContext -> (Diffusion IO -> Logic IO) -> (Diffusion IO -> IO t) -> IO t -runServer pm NodeParams {..} ekgNodeMetrics shdnContext mkLogic act = exitOnShutdown $ +runServer pm pc NodeParams {..} ekgNodeMetrics shdnContext mkLogic act = exitOnShutdown $ diffusionLayerFull fdconf npNetworkConfig (Just ekgNodeMetrics) @@ -175,7 +172,7 @@ runServer pm NodeParams {..} ekgNodeMetrics shdnContext mkLogic act = exitOnShut where fdconf = FullDiffusionConfiguration { fdcProtocolMagic = pm - , fdcProtocolConstants = protocolConstants + , fdcProtocolConstants = pc , fdcRecoveryHeadersMessage = recoveryHeadersMessage , fdcLastKnownBlockVersion = lastKnownBlockVersion , fdcConvEstablishTimeout = networkConnectionTimeout diff --git a/lib/src/Pos/Launcher/Scenario.hs b/lib/src/Pos/Launcher/Scenario.hs index 84fd914222c..6d8273f7ec9 100644 --- a/lib/src/Pos/Launcher/Scenario.hs +++ b/lib/src/Pos/Launcher/Scenario.hs @@ -20,7 +20,7 @@ import System.Wlog (WithLogger, askLoggerName, logInfo) import Pos.Context (getOurPublicKey) import Pos.Core (GenesisData (gdBootStakeholders, gdHeavyDelegation), GenesisDelegation (..), GenesisWStakeholders (..), - addressHash, gdFtsSeed, genesisData) + ProtocolConstants, addressHash, gdFtsSeed, genesisData) import Pos.Crypto (ProtocolMagic, pskDelegatePk) import qualified Pos.DB.BlockIndex as DB import qualified Pos.GState as GS @@ -104,17 +104,16 @@ runNode' NodeResources {..} workers' plugins' = \diffusion -> do -- | Entry point of full node. -- Initialization, running of workers, running of plugins. runNode - :: ( HasCompileInfo - , HasTxpConfiguration - , WorkMode ctx m - ) + :: (HasCompileInfo, HasTxpConfiguration, WorkMode ctx m) => ProtocolMagic + -> ProtocolConstants -> NodeResources ext -> [Diffusion m -> m ()] - -> Diffusion m -> m () -runNode pm nr plugins = runNode' nr workers' plugins + -> Diffusion m + -> m () +runNode pm pc nr plugins = runNode' nr workers' plugins where - workers' = allWorkers pm nr + workers' = allWorkers pm pc nr -- | This function prints a very useful message when node is started. nodeStartMsg :: (HasUpdateConfiguration, WithLogger m) => m () diff --git a/lib/src/Pos/Logic/Full.hs b/lib/src/Pos/Logic/Full.hs index 8f5c23306b9..2aa6198e043 100644 --- a/lib/src/Pos/Logic/Full.hs +++ b/lib/src/Pos/Logic/Full.hs @@ -22,8 +22,9 @@ import qualified Pos.Block.Network as Block import Pos.Block.Types (RecoveryHeader, RecoveryHeaderTag) import Pos.Communication (NodeId) import Pos.Core (Block, BlockHeader, BlockVersionData, - HasConfiguration, HeaderHash, ProxySKHeavy, StakeholderId, - TxAux (..), addressHash, getCertId, lookupVss) + HasConfiguration, HeaderHash, ProtocolConstants, + ProxySKHeavy, StakeholderId, TxAux (..), addressHash, + getCertId, kEpochSlots, lookupVss, pcBlkSecurityParam) import Pos.Core.Chrono (NE, NewestFirst, OldestFirst) import Pos.Core.Ssc (getCommitmentsMap) import Pos.Core.Update (UpdateProposal (..), UpdateVote (..)) @@ -98,15 +99,19 @@ type LogicWorkMode ctx m = -- | A stop-gap full logic layer based on the RealMode. It just uses the -- monadX constraints to do most of its work. logicFull - :: forall ctx m . - ( LogicWorkMode ctx m ) + :: forall ctx m + . LogicWorkMode ctx m => ProtocolMagic + -> ProtocolConstants -> StakeholderId -> SecurityParams -> (JLEvent -> m ()) -- ^ JSON log callback. FIXME replace by structured logging solution -> Logic m -logicFull pm ourStakeholderId securityParams jsonLogTx = +logicFull pm pc ourStakeholderId securityParams jsonLogTx = let + k = pcBlkSecurityParam pc + epochSlots = kEpochSlots k + getSerializedBlock :: HeaderHash -> m (Maybe SerializedBlock) getSerializedBlock = DB.dbGetSerBlock @@ -123,7 +128,7 @@ logicFull pm ourStakeholderId securityParams jsonLogTx = getAdoptedBVData = gsAdoptedBVData recoveryInProgress :: m Bool - recoveryInProgress = Recovery.recoveryInProgress + recoveryInProgress = Recovery.recoveryInProgress epochSlots getBlockHeader :: HeaderHash -> m (Maybe BlockHeader) getBlockHeader = DB.getHeader @@ -132,103 +137,140 @@ logicFull pm ourStakeholderId securityParams jsonLogTx = :: Maybe Word -- ^ Optional limit on how many to pull in. -> HeaderHash -> HeaderHash - -> m (Either Block.GetHashesRangeError (OldestFirst NE HeaderHash)) + -> m + ( Either + Block.GetHashesRangeError + (OldestFirst NE HeaderHash) + ) getHashesRange = Block.getHashesRange getBlockHeaders :: Maybe Word -- ^ Optional limit on how many to pull in. -> NonEmpty HeaderHash -> Maybe HeaderHash - -> m (Either Block.GetHeadersFromManyToError (NewestFirst NE BlockHeader)) + -> m + ( Either + Block.GetHeadersFromManyToError + (NewestFirst NE BlockHeader) + ) getBlockHeaders = Block.getHeadersFromManyTo - getLcaMainChain :: OldestFirst [] BlockHeader -> m (OldestFirst [] BlockHeader) + getLcaMainChain + :: OldestFirst [] BlockHeader -> m (OldestFirst [] BlockHeader) getLcaMainChain = Block.lcaWithMainChainSuffix postBlockHeader :: BlockHeader -> NodeId -> m () - postBlockHeader = Block.handleUnsolicitedHeader pm + postBlockHeader = Block.handleUnsolicitedHeader pm epochSlots postPskHeavy :: ProxySKHeavy -> m Bool postPskHeavy = Delegation.handlePsk pm - postTx = KeyVal - { toKey = pure . Tagged . hash . taTx . getTxMsgContents - , handleInv = \(Tagged txId) -> not . HM.member txId . _mpLocalTxs <$> withTxpLocalData getMemPool - , handleReq = \(Tagged txId) -> fmap TxMsgContents . HM.lookup txId . _mpLocalTxs <$> withTxpLocalData getMemPool - , handleData = \(TxMsgContents txAux) -> Txp.handleTxDo pm jsonLogTx txAux + postTx = KeyVal + { toKey = pure . Tagged . hash . taTx . getTxMsgContents + , handleInv = \(Tagged txId) -> + not + . HM.member txId + . _mpLocalTxs + <$> withTxpLocalData getMemPool + , handleReq = \(Tagged txId) -> + fmap TxMsgContents + . HM.lookup txId + . _mpLocalTxs + <$> withTxpLocalData getMemPool + , handleData = \(TxMsgContents txAux) -> + Txp.handleTxDo pm epochSlots jsonLogTx txAux } postUpdate = KeyVal - { toKey = \(up, _) -> pure . tag $ hash up - , handleInv = Update.isProposalNeeded . unTagged - , handleReq = Update.getLocalProposalNVotes . unTagged - , handleData = Update.handleProposal pm + { toKey = \(up, _) -> pure . tag $ hash up + , handleInv = Update.isProposalNeeded . unTagged + , handleReq = Update.getLocalProposalNVotes . unTagged + , handleData = Update.handleProposal pm k } - where - tag = tagWith (Proxy :: Proxy (UpdateProposal, [UpdateVote])) + where tag = tagWith (Proxy :: Proxy (UpdateProposal, [UpdateVote])) postVote = KeyVal - { toKey = \UnsafeUpdateVote{..} -> pure $ tag (uvProposalId, uvKey, uvDecision) - , handleInv = \(Tagged (id, pk, dec)) -> Update.isVoteNeeded id pk dec - , handleReq = \(Tagged (id, pk, dec)) -> Update.getLocalVote id pk dec - , handleData = Update.handleVote pm + { toKey = \UnsafeUpdateVote {..} -> + pure $ tag (uvProposalId, uvKey, uvDecision) + , handleInv = \(Tagged (id, pk, dec)) -> + Update.isVoteNeeded id pk dec + , handleReq = \(Tagged (id, pk, dec)) -> + Update.getLocalVote id pk dec + , handleData = Update.handleVote pm k } - where - tag = tagWith (Proxy :: Proxy UpdateVote) + where tag = tagWith (Proxy :: Proxy UpdateVote) postSscCommitment = postSscCommon CommitmentMsg (\(MCCommitment (pk, _, _)) -> addressHash pk) - (\id tm -> MCCommitment <$> tm ^. tmCommitments . to getCommitmentsMap . at id) - (\(MCCommitment comm) -> sscProcessCommitment pm comm) + (\id tm -> + MCCommitment + <$> tm + ^. tmCommitments + . to getCommitmentsMap + . at id + ) + (\(MCCommitment comm) -> sscProcessCommitment pm pc comm) postSscOpening = postSscCommon OpeningMsg (\(MCOpening key _) -> key) (\id tm -> MCOpening id <$> tm ^. tmOpenings . at id) - (\(MCOpening key open) -> sscProcessOpening pm key open) + (\(MCOpening key open) -> sscProcessOpening pm pc key open) postSscShares = postSscCommon SharesMsg (\(MCShares key _) -> key) (\id tm -> MCShares id <$> tm ^. tmShares . at id) - (\(MCShares key shares) -> sscProcessShares pm key shares) + (\(MCShares key shares) -> sscProcessShares pm pc key shares) postSscVssCert = postSscCommon VssCertificateMsg (\(MCVssCertificate vc) -> getCertId vc) (\id tm -> MCVssCertificate <$> lookupVss id (tm ^. tmCertificates)) - (\(MCVssCertificate cert) -> sscProcessCertificate pm cert) + (\(MCVssCertificate cert) -> sscProcessCertificate pm pc cert) postSscCommon - :: ( Buildable err, Buildable contents ) + :: (Buildable err, Buildable contents) => SscTag -> (contents -> StakeholderId) -> (StakeholderId -> TossModifier -> Maybe contents) -> (contents -> m (Either err ())) -> KeyVal (Tagged contents StakeholderId) contents m postSscCommon sscTag contentsToKey toContents processData = KeyVal - { toKey = pure . tagWith contentsProxy . contentsToKey - , handleInv = sscIsDataUseful sscTag . unTagged - , handleReq = \(Tagged addr) -> toContents addr . view ldModifier <$> sscRunLocalQuery ask + { toKey = pure . tagWith contentsProxy . contentsToKey + , handleInv = sscIsDataUseful k sscTag . unTagged + , handleReq = \(Tagged addr) -> + toContents addr . view ldModifier <$> sscRunLocalQuery ask , handleData = \dat -> do - let addr = contentsToKey dat - -- [CSL-685] TODO: Add here malicious emulation for network - -- addresses when TW will support getting peer address - -- properly - -- Stale comment? - handleDataDo dat addr =<< shouldIgnorePkAddress addr + let addr = contentsToKey dat + -- [CSL-685] TODO: Add here malicious emulation for network + -- addresses when TW will support getting peer address + -- properly + -- Stale comment? + handleDataDo dat addr =<< shouldIgnorePkAddress addr } where - contentsProxy = (const Proxy :: (contents -> k) -> Proxy contents) contentsToKey + contentsProxy = + (const Proxy :: (contents -> k) -> Proxy contents) contentsToKey ignoreFmt = - "Malicious emulation: data "%build%" for id "%build%" is ignored" + "Malicious emulation: data " + % build + % " for id " + % build + % " is ignored" handleDataDo dat id shouldIgnore | shouldIgnore = False <$ logDebug (sformat ignoreFmt id dat) - | otherwise = sscProcessMessage processData dat + | otherwise = sscProcessMessage processData dat sscProcessMessage sscProcessMessageDo dat = sscProcessMessageDo dat >>= \case - Left err -> False <$ logDebug (sformat ("Data is rejected, reason: "%build) err) + Left err -> + False + <$ logDebug + (sformat + ("Data is rejected, reason: " % build) + err + ) Right () -> return True - - in Logic {..} + in + Logic {..} diff --git a/lib/src/Pos/Recovery/Instance.hs b/lib/src/Pos/Recovery/Instance.hs index 5b3e1a517f5..e59269b2b06 100644 --- a/lib/src/Pos/Recovery/Instance.hs +++ b/lib/src/Pos/Recovery/Instance.hs @@ -13,8 +13,7 @@ import Control.Monad.Except (runExceptT, throwError) import Pos.Block.BHelpers () import Pos.Block.Types (RecoveryHeader, RecoveryHeaderTag) -import Pos.Core (HasProtocolConstants, epochOrSlotG, - epochOrSlotToSlot, flattenSlotId) +import Pos.Core (epochOrSlotG, epochOrSlotToSlot, flattenSlotId) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead) import Pos.Infra.Recovery.Info (MonadRecoveryInfo (..), @@ -28,22 +27,22 @@ instance ( Monad m , MonadSlots ctx m , MonadReader ctx m , HasLens RecoveryHeaderTag ctx RecoveryHeader - , HasProtocolConstants ) => MonadRecoveryInfo m where - getSyncStatus lagBehindParam = + getSyncStatus epochSlots lagBehindParam = fmap convertRes . runExceptT $ do recoveryIsInProgress >>= \case False -> pass True -> throwError SSDoingRecovery - curSlot <- note SSUnknownSlot =<< getCurrentSlot + curSlot <- note SSUnknownSlot =<< getCurrentSlot epochSlots tipHeader <- lift DB.getTipHeader let tipSlot = epochOrSlotToSlot (tipHeader ^. epochOrSlotG) unless (tipSlot <= curSlot) $ throwError SSInFuture {sslbCurrentSlot = curSlot, sslbTipSlot = tipSlot} - let slotDiff = flattenSlotId curSlot - flattenSlotId tipSlot + let slotDiff = flattenSlotId epochSlots curSlot + - flattenSlotId epochSlots tipSlot unless (slotDiff < fromIntegral lagBehindParam) $ throwError SSLagBehind diff --git a/lib/src/Pos/WorkMode.hs b/lib/src/Pos/WorkMode.hs index 9d7af72d9d0..4d78fe83eb3 100644 --- a/lib/src/Pos/WorkMode.hs +++ b/lib/src/Pos/WorkMode.hs @@ -147,9 +147,7 @@ instance {-# OVERLAPPING #-} HasLoggerName (RealMode ext) where instance {-# OVERLAPPING #-} CanJsonLog (RealMode ext) where jsonLog = jsonLogDefault -instance (HasConfiguration, MonadSlotsData ctx (RealMode ext)) - => MonadSlots ctx (RealMode ext) - where +instance MonadSlotsData ctx (RealMode ext) => MonadSlots ctx (RealMode ext) where getCurrentSlot = getCurrentSlotSimple getCurrentSlotBlocking = getCurrentSlotBlockingSimple getCurrentSlotInaccurate = getCurrentSlotInaccurateSimple @@ -172,7 +170,7 @@ instance HasConfiguration => MonadDB (RealMode ext) where instance MonadBListener (RealMode ext) where onApplyBlocks = onApplyBlocksStub - onRollbackBlocks = onRollbackBlocksStub + onRollbackBlocks _ = onRollbackBlocksStub type instance MempoolExt (RealMode ext) = ext diff --git a/lib/src/Pos/Worker.hs b/lib/src/Pos/Worker.hs index 3ccb0bbf55d..8739426ca81 100644 --- a/lib/src/Pos/Worker.hs +++ b/lib/src/Pos/Worker.hs @@ -13,6 +13,7 @@ import Pos.Block.Worker (blkWorkers) -- Message instances. import Pos.Communication.Message () import Pos.Context (NodeContext (..)) +import Pos.Core (ProtocolConstants, pcBlkSecurityParam, pcEpochSlots) import Pos.Crypto (ProtocolMagic) import Pos.Delegation.Worker (dlgWorkers) import Pos.Infra.Diffusion.Types (Diffusion) @@ -30,17 +31,18 @@ allWorkers :: forall ext ctx m . (HasTxpConfiguration, WorkMode ctx m) => ProtocolMagic + -> ProtocolConstants -> NodeResources ext -> [Diffusion m -> m ()] -allWorkers pm NodeResources {..} = mconcat - [ sscWorkers pm - , usWorkers - , blkWorkers pm +allWorkers pm pc NodeResources {..} = mconcat + [ sscWorkers pm pc + , usWorkers (pcBlkSecurityParam pc) + , blkWorkers pm pc , dlgWorkers , [properSlottingWorker, staticConfigMonitoringWorker] ] where topology = ncTopology ncNetworkConfig NodeContext {..} = nrContext - properSlottingWorker = const logNewSlotWorker + properSlottingWorker = const $ logNewSlotWorker $ pcEpochSlots pc staticConfigMonitoringWorker = const (launchStaticConfigMonitoring topology) diff --git a/lib/src/Test/Pos/Configuration.hs b/lib/src/Test/Pos/Configuration.hs index d8f98fc4444..0be808540d0 100644 --- a/lib/src/Test/Pos/Configuration.hs +++ b/lib/src/Test/Pos/Configuration.hs @@ -31,7 +31,6 @@ import Pos.Core (BlockVersionData, HasConfiguration, withGenesisSpec) import Pos.Core.Configuration (CoreConfiguration (..), GenesisConfiguration (..)) import Pos.Core.Genesis (GenesisSpec (..)) -import Pos.Crypto (ProtocolMagic) import Pos.Delegation (HasDlgConfiguration, withDlgConfiguration) import Pos.Infra.Ntp.Configuration (NtpConfiguration) import Pos.Launcher.Configuration (Configuration (..), @@ -93,10 +92,11 @@ withDefDlgConfiguration = withDlgConfiguration (ccDlg defaultTestConf) withDefTxpConfiguration :: (HasTxpConfiguration => r) -> r withDefTxpConfiguration = withTxpConfiguration (ccTxp defaultTestConf) -withDefConfiguration :: (HasConfiguration => ProtocolMagic -> r) -> r -withDefConfiguration = withGenesisSpec 0 (ccCore defaultTestConf) +withDefConfiguration :: (HasConfiguration => r) -> r +withDefConfiguration f = withGenesisSpec 0 (ccCore defaultTestConf) (\_ _ -> f) -withStaticConfigurations :: (HasStaticConfigurations => NtpConfiguration -> r) -> r +withStaticConfigurations + :: (HasStaticConfigurations => NtpConfiguration -> r) -> r withStaticConfigurations patak = withDefNodeConfiguration $ withDefSscConfiguration $ @@ -106,7 +106,6 @@ withStaticConfigurations patak = withDefTxpConfiguration $ withDefNtpConfiguration patak -withDefConfigurations - :: (HasConfigurations => NtpConfiguration -> ProtocolMagic -> r) -> r +withDefConfigurations :: (HasConfigurations => NtpConfiguration -> r) -> r withDefConfigurations bardaq = withDefConfiguration $ withStaticConfigurations bardaq diff --git a/lib/test/Test/Pos/Block/Identity/SafeCopySpec.hs b/lib/test/Test/Pos/Block/Identity/SafeCopySpec.hs index d60a13e9bb0..7bf8237fb63 100644 --- a/lib/test/Test/Pos/Block/Identity/SafeCopySpec.hs +++ b/lib/test/Test/Pos/Block/Identity/SafeCopySpec.hs @@ -12,10 +12,9 @@ import Pos.SafeCopy () import Test.Pos.Binary.Helpers (safeCopyTest) import Test.Pos.Block.Arbitrary () -import Test.Pos.Configuration (withDefConfiguration) spec :: Spec -spec = withDefConfiguration $ \_ -> describe "Block types" $ do +spec = describe "Block types" $ do describe "SafeCopy instances" $ do describe "GenericBlockHeader" $ do describe "GenesisBlockHeader" $ do diff --git a/lib/test/Test/Pos/Cbor/CborSpec.hs b/lib/test/Test/Pos/Cbor/CborSpec.hs index 5ae29da24dc..da3a0c2f0b7 100644 --- a/lib/test/Test/Pos/Cbor/CborSpec.hs +++ b/lib/test/Test/Pos/Cbor/CborSpec.hs @@ -67,7 +67,7 @@ type UpId' = Tagged (U.UpdateProposal, [U.UpdateVote])U.UpId ---------------------------------------- spec :: Spec -spec = withDefConfiguration $ \_ -> do +spec = withDefConfiguration $ do describe "Cbor.Bi instances" $ do modifyMaxSuccess (const 1000) $ do describe "Lib/core instances" $ do diff --git a/lib/test/Test/Pos/Diffusion/BlockSpec.hs b/lib/test/Test/Pos/Diffusion/BlockSpec.hs index 23324b0b7ce..6ff090fa8d8 100644 --- a/lib/test/Test/Pos/Diffusion/BlockSpec.hs +++ b/lib/test/Test/Pos/Diffusion/BlockSpec.hs @@ -230,7 +230,7 @@ generateBlocks blocks = doGenerateBlock :: Int -> Block doGenerateBlock seed = let size = 4 in - force $ Right (generateMainBlock protocolMagic protocolConstants seed size) + force $ Right (generateMainBlock protocolMagic seed size) doGenerateBlocks :: Int -> [Block] doGenerateBlocks 0 = [] @@ -290,4 +290,3 @@ spec = describe "Blockdownload" $ do it "Batch of blocks" $ do r <- batchSimple 2200 r `shouldBe` True - diff --git a/lib/test/Test/Pos/Genesis/CanonicalSpec.hs b/lib/test/Test/Pos/Genesis/CanonicalSpec.hs index 0dcda6546d6..b6c279ac210 100644 --- a/lib/test/Test/Pos/Genesis/CanonicalSpec.hs +++ b/lib/test/Test/Pos/Genesis/CanonicalSpec.hs @@ -13,12 +13,11 @@ import Pos.Core.Genesis (GenesisAvvmBalances, GenesisData, GenesisDelegation, GenesisProtocolConstants, GenesisWStakeholders) -import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.Core.Arbitrary () import Test.Pos.Helpers (canonicalJsonTest) spec :: Spec -spec = withDefConfiguration $ \_ -> describe "Genesis" $ modifyMaxSuccess (const 10) $ do +spec = describe "Genesis" $ modifyMaxSuccess (const 10) $ do describe "Canonical encoding" $ do canonicalJsonTest @GenesisProtocolConstants canonicalJsonTest @GenesisAvvmBalances diff --git a/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs b/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs index 9124c1fefec..ffd2889a2cd 100644 --- a/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs +++ b/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs @@ -29,7 +29,7 @@ import Test.Pos.Lrc.Arbitrary (GenesisMpcThd, import Test.Pos.Util.QuickCheck.Property (qcIsLeft) spec :: Spec -spec = withDefConfiguration $ \_ -> describe "computeSharesDistr" $ do +spec = withDefConfiguration $ describe "computeSharesDistr" $ do prop emptyRichmenStakesDesc emptyRichmenStakes modifyMaxSuccess (const 3) $ prop invalidStakeErrorsDesc invalidStakeErrors diff --git a/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs b/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs index a7f765255c8..af9601c9224 100644 --- a/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs +++ b/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs @@ -44,10 +44,11 @@ import Test.Pos.Lrc.Arbitrary (GenesisMpcThd, ValidRichmenStakes (..)) import Test.Pos.Util.QuickCheck.Property (qcElem, qcFail, qcIsRight) import Test.Pos.Configuration (withDefConfiguration) +import Test.Pos.Core.Dummy (dummyK) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) spec :: Spec -spec = withDefConfiguration $ \_ -> describe "Ssc.Base" $ do +spec = withDefConfiguration $ describe "Ssc.Base" $ do describe "verifyCommitment" $ do prop description_verifiesOkComm verifiesOkComm describe "verifyCommitmentSignature" $ do @@ -66,7 +67,7 @@ spec = withDefConfiguration $ \_ -> describe "Ssc.Base" $ do prop description_checksBadOpeningsPayload checksBadOpeningsPayload describe "checkSharesPayload" $ do prop description_emptyPayload - (\e mrs hm -> emptyPayload (checkSharesPayload e) $ HM.insert e hm mrs) + (\e mrs hm -> emptyPayload (checkSharesPayload dummyK e) $ HM.insert e hm mrs) prop description_checksGoodSharesPayload checksGoodSharesPayload prop description_checksBadSharesPayload checksBadSharesPayload describe "checkCertificatesPayload" $ do @@ -156,7 +157,7 @@ emptyPayloadComms GoodPayload {..} = let e :: EpochIndex validMrs :: MultiRichmenStakes (e, validMrs) = (gpEpoch, gpMultiRichmenStakes) - in emptyPayload (checkCommitmentsPayload e) validMrs + in emptyPayload (checkCommitmentsPayload dummyK e) validMrs data GoodPayload p = GoodPayload { gpEpoch :: !EpochIndex @@ -195,7 +196,7 @@ instance HasConfiguration => Arbitrary GoodCommsPayload where -- in 'gsVssCertificate'. -- This is because rolling back slots is and should be tested elsewhere. _sgsVssCertificates <- VssCertData - <$> (pure . EpochOrSlot . Right . crucialSlot $ gpEpoch) + <$> (pure . EpochOrSlot . Right . crucialSlot dummyK $ gpEpoch) <*> pure stableCerts <*> arbitrary <*> arbitrary @@ -214,7 +215,7 @@ instance HasConfiguration => Arbitrary GoodCommsPayload where -- TODO: Account for 'CommSharesOnWrongParticipants' failure checksGoodCommsPayload :: HasConfiguration => GoodCommsPayload -> Bool checksGoodCommsPayload (GoodPayload epoch sgs commsMap mrs) = - case tossRunner mrs sgs $ checkCommitmentsPayload epoch commsMap of + case tossRunner mrs sgs $ checkCommitmentsPayload dummyK epoch commsMap of Left (CommSharesOnWrongParticipants _) -> True Right _ -> True _ -> False @@ -234,7 +235,7 @@ checksBadCommsPayload seed = let mrsWithMissingEpoch = HM.delete epoch mrs noRichmen = - tossRunner mrsWithMissingEpoch sgs $ checkCommitmentsPayload epoch commsMap + tossRunner mrsWithMissingEpoch sgs $ checkCommitmentsPayload dummyK epoch commsMap res1 = case noRichmen of Left (NoRichmen e) -> e == epoch _ -> False @@ -244,7 +245,7 @@ checksBadCommsPayload newCommsMap = wrapCMap (HM.insert sid comm) commsMap committingNoParticipants = - tossRunner mrs sgs $ checkCommitmentsPayload epoch newCommsMap + tossRunner mrs sgs $ checkCommitmentsPayload dummyK epoch newCommsMap res2 = case committingNoParticipants of Left (CommittingNoParticipants (s :| [])) -> s == sid _ -> False @@ -263,7 +264,7 @@ checksBadCommsPayload sgs' = sgs & sgsCommitments %~ wrapCMap (HM.insert someRichman comm) commitmentAlreadySent = - tossRunner mrs sgs' $ checkCommitmentsPayload epoch commsMap + tossRunner mrs sgs' $ checkCommitmentsPayload dummyK epoch commsMap res3 = case commitmentAlreadySent of Left (CommitmentAlreadySent (s :| [])) -> s == someRichman _ -> False @@ -394,7 +395,7 @@ instance HasConfiguration => Arbitrary GoodSharesPayload where -- 'lastKnownEoS' field: 'checkSharesPayload' is called with the same epoch as the -- 'lastKnownEoS' in 'gsVssCertificate'. _sgsVssCertificates <- VssCertData - <$> (pure . EpochOrSlot . Right . crucialSlot $ gpEpoch) + <$> (pure . EpochOrSlot . Right . crucialSlot dummyK $ gpEpoch) <*> pure stableCerts <*> arbitrary <*> arbitrary @@ -425,7 +426,7 @@ instance HasConfiguration => Arbitrary GoodSharesPayload where --make the already non-trivial arbitrary instance for 'GoodSharesPayload' unmanageable. checksGoodSharesPayload :: HasConfiguration => GoodSharesPayload -> Bool checksGoodSharesPayload (GoodPayload epoch sgs sharesMap mrs) = - case tossRunner mrs sgs $ checkSharesPayload epoch sharesMap of + case tossRunner mrs sgs $ checkSharesPayload dummyK epoch sharesMap of Left (DecrSharesNotMatchCommitment _) -> True Right _ -> True _ -> False @@ -454,11 +455,11 @@ checksBadSharesPayload (GoodPayload epoch g@SscGlobalState {..} sm mrs) pk ne ce mrsWithMissingEpoch = HM.delete epoch mrs noRichmen = - tossRunner mrsWithMissingEpoch sgs $ checkSharesPayload epoch sharesMap + tossRunner mrsWithMissingEpoch sgs $ checkSharesPayload dummyK epoch sharesMap res1 = noRichmen === Left (NoRichmen epoch) newSharesMap = HM.insert sid mempty sharesMap - sharesNotRichmen = tossRunner mrs sgs $ checkSharesPayload epoch newSharesMap + sharesNotRichmen = tossRunner mrs sgs $ checkSharesPayload dummyK epoch newSharesMap res2 = case sharesNotRichmen of Left (SharesNotRichmen nes) -> sid `qcElem` nes _ -> qcFail $ "expected " <> show sharesNotRichmen <> @@ -466,7 +467,7 @@ checksBadSharesPayload (GoodPayload epoch g@SscGlobalState {..} sm mrs) pk ne ce newerSharesMap = fmap (HM.insert sid ne) sharesMap internalShareWithoutComm = - tossRunner mrs sgs $ checkSharesPayload epoch newerSharesMap + tossRunner mrs sgs $ checkSharesPayload dummyK epoch newerSharesMap res3 = case internalShareWithoutComm of Left (InternalShareWithoutCommitment nes) -> sid `qcElem` nes _ -> qcFail $ "expected " <> show internalShareWithoutComm <> @@ -482,7 +483,7 @@ checksBadSharesPayload (GoodPayload epoch g@SscGlobalState {..} sm mrs) pk ne ce vcd { certs = fst $ insertVss cert' certs} mrs' = HM.update (Just . HM.insert sid (mkCoin 0)) epoch mrs sharesAlreadySent = - tossRunner mrs' sgs' $ checkSharesPayload epoch newestSharesMap + tossRunner mrs' sgs' $ checkSharesPayload dummyK epoch newestSharesMap res4 = case sharesAlreadySent of Left (SharesAlreadySent nes) -> sid `qcElem` nes _ -> qcFail $ "expected " <> show sharesAlreadySent <> diff --git a/lib/test/Test/Pos/Ssc/Toss/PureSpec.hs b/lib/test/Test/Pos/Ssc/Toss/PureSpec.hs index 50d8bcdab8c..c61ce78bd88 100644 --- a/lib/test/Test/Pos/Ssc/Toss/PureSpec.hs +++ b/lib/test/Test/Pos/Ssc/Toss/PureSpec.hs @@ -27,7 +27,7 @@ import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.Core.Arbitrary () spec :: Spec -spec = withDefConfiguration $ \_ -> describe "Toss" $ do +spec = withDefConfiguration $ describe "Toss" $ do let smaller n = modifyMaxSuccess (const n) describe "PureToss" $ smaller 30 $ do prop "Adding and deleting a signed commitment in the 'PureToss' monad is the\ @@ -53,7 +53,7 @@ data TossAction | SetEpochOrSlot EpochOrSlot deriving (Show, Eq, Generic) -instance HasConfiguration => Arbitrary TossAction where +instance Arbitrary TossAction where arbitrary = genericArbitrary shrink = genericShrink diff --git a/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs b/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs index 74fdffd2a54..c5c24d0c46c 100644 --- a/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs +++ b/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs @@ -20,8 +20,7 @@ import Test.QuickCheck (Arbitrary (..), Gen, Property, choose, import Pos.Arbitrary.Ssc () import Pos.Core (EpochIndex (..), EpochOrSlot (..), HasConfiguration, SlotId (..), VssCertificate (..), getCertId, - getVssCertificatesMap, mkVssCertificate, - slotSecurityParam) + getVssCertificatesMap, mkVssCertificate) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Slotting (flattenEpochOrSlot, unflattenSlotId) import Pos.Ssc (SscGlobalState (..), VssCertData (..), delete, empty, @@ -31,11 +30,12 @@ import Pos.Ssc (SscGlobalState (..), VssCertData (..), delete, empty, import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.Core.Arbitrary () +import Test.Pos.Core.Dummy (dummyEpochSlots, dummySlotSecurityParam) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Property (qcIsJust) spec :: Spec -spec = withDefConfiguration $ \_ -> describe "Ssc.VssCertData" $ do +spec = withDefConfiguration $ describe "Ssc.VssCertData" $ do describe "verifyInsertVssCertData" $ prop description_verifyInsertVssCertData verifyInsertVssCertData describe "verifyDeleteVssCertData" $ @@ -179,14 +179,14 @@ instance HasConfiguration => Arbitrary RollbackData where arbitrary = do goodVssCertData@(VssCertData {..}) <- getVssCertData <$> arbitrary certsToRollbackN <- choose (0, 100) >>= choose . (0,) - slotsToRollback <- choose (1, slotSecurityParam) - let lastKEoSWord = flattenEpochOrSlot lastKnownEoS + slotsToRollback <- choose (1, dummySlotSecurityParam) + let lastKEoSWord = flattenEpochOrSlot dummyEpochSlots lastKnownEoS rollbackFrom = fromIntegral slotsToRollback + lastKEoSWord rollbackGen = do sk <- arbitrary binVssPK <- arbitrary thisEpoch <- - siEpoch . unflattenSlotId <$> + siEpoch . unflattenSlotId dummyEpochSlots <$> choose (succ lastKEoSWord, rollbackFrom) return $ mkVssCertificate dummyProtocolMagic sk binVssPK thisEpoch certsToRollback <- nubOrdOn vcVssKey <$> @@ -195,15 +195,14 @@ instance HasConfiguration => Arbitrary RollbackData where lastKnownEoS certsToRollback -verifyRollback - :: HasConfiguration => RollbackData -> Gen Property +verifyRollback :: HasConfiguration => RollbackData -> Gen Property verifyRollback (Rollback oldSscGlobalState rollbackEoS vssCerts) = do let certAdder vcd = foldl' (flip insert) vcd vssCerts newSscGlobalState@(SscGlobalState _ _ _ newVssCertData) = oldSscGlobalState & sgsVssCertificates %~ certAdder (_, SscGlobalState _ _ _ rolledVssCertData, _) <- runPureToss newSscGlobalState $ - rollbackSsc rollbackEoS (NewestFirst []) + rollbackSsc dummyEpochSlots rollbackEoS (NewestFirst []) pure $ conjoin $ vssCerts <&> \cert -> let id = getCertId cert in counterexample ("haven't found cert with id " <> diff --git a/lib/test/Test/Pos/Types/BlockSpec.hs b/lib/test/Test/Pos/Types/BlockSpec.hs index 4575f606145..822f42bde6d 100644 --- a/lib/test/Test/Pos/Types/BlockSpec.hs +++ b/lib/test/Test/Pos/Types/BlockSpec.hs @@ -29,19 +29,22 @@ import Test.Pos.Crypto.Dummy (dummyProtocolMagic) -- This tests are quite slow, hence max success is at most 20. spec :: Spec -spec = withDefConfiguration $ \_ -> - describe "Block properties" $ modifyMaxSuccess (min 20) $ do - describe "mkMainHeader" $ do - prop mainHeaderFormationDesc mainHeaderFormation - describe "mkGenesisHeader" $ do - prop genesisHeaderFormationDesc genesisHeaderFormation - describe "verifyHeader" $ do - prop verifyHeaderDesc validateGoodMainHeader - prop invalidProtocolMagicHeaderDesc - validateBadProtocolMagicMainHeader - describe "verifyHeaders" $ modifyMaxSuccess (const 1) $ do - prop verifyHeadersDesc validateGoodHeaderChain - emptyHeaderChain (NewestFirst []) +spec = + withDefConfiguration + $ describe "Block properties" + $ modifyMaxSuccess (min 20) + $ do + describe "mkMainHeader" $ do + prop mainHeaderFormationDesc mainHeaderFormation + describe "mkGenesisHeader" $ do + prop genesisHeaderFormationDesc genesisHeaderFormation + describe "verifyHeader" $ do + prop verifyHeaderDesc validateGoodMainHeader + prop invalidProtocolMagicHeaderDesc + validateBadProtocolMagicMainHeader + describe "verifyHeaders" $ modifyMaxSuccess (const 1) $ do + prop verifyHeadersDesc validateGoodHeaderChain + emptyHeaderChain (NewestFirst []) where mainHeaderFormationDesc = "Manually generating a main header block and using\ diff --git a/lib/test/Test/Pos/Types/Identity/SafeCopySpec.hs b/lib/test/Test/Pos/Types/Identity/SafeCopySpec.hs index 52dcdd8f328..2debfb4a56e 100644 --- a/lib/test/Test/Pos/Types/Identity/SafeCopySpec.hs +++ b/lib/test/Test/Pos/Types/Identity/SafeCopySpec.hs @@ -13,12 +13,11 @@ import qualified Pos.Core.Txp as Txp import Pos.SafeCopy () import Test.Pos.Binary.Helpers (safeCopyTest) -import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.Txp.Arbitrary () import Test.Pos.Txp.Arbitrary.Network () spec :: Spec -spec = withDefConfiguration $ \_ -> describe "Types" $ do +spec = describe "Types" $ do describe "SafeCopy instances" $ do safeCopyTest @Core.EpochIndex safeCopyTest @Core.LocalSlotIndex diff --git a/lib/test/Test/Pos/Update/PollSpec.hs b/lib/test/Test/Pos/Update/PollSpec.hs index d7664864870..10054fd9f82 100644 --- a/lib/test/Test/Pos/Update/PollSpec.hs +++ b/lib/test/Test/Pos/Update/PollSpec.hs @@ -16,8 +16,8 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, genericShrink) import Pos.Core (ApplicationName, BlockVersion (..), - BlockVersionData (..), HasConfiguration, - SoftwareVersion (..), StakeholderId, addressHash) + BlockVersionData (..), SoftwareVersion (..), + StakeholderId, addressHash) import Pos.Core.Update (UpId, UpdateProposal (..)) import Pos.Crypto (hash) import Pos.Infra.Slotting.Types (SlottingData) @@ -26,12 +26,11 @@ import qualified Pos.Update.Poll as Poll import qualified Pos.Util.Modifier as MM import Test.Pos.Binary.Helpers () -import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.Update.Arbitrary () import Test.Pos.Util.QuickCheck.Property (formsMonoid) spec :: Spec -spec = withDefConfiguration $ \_ -> describe "Poll" $ do +spec = describe "Poll" $ do let smaller n = modifyMaxSuccess (const n) describe "modifyPollModifier" $ smaller 30 $ do prop @@ -91,7 +90,7 @@ data PollAction | SetEpochProposers (HashSet StakeholderId) deriving (Show, Eq, Generic) -instance HasConfiguration => Arbitrary PollAction where +instance Arbitrary PollAction where arbitrary = genericArbitrary shrink = genericShrink @@ -192,8 +191,7 @@ perform = foldl (>>) (return ()) . map actionToMonad -- | Operational equivalence operator in the 'PurePoll' monad. To be used when -- equivalence between two sequences of actions in 'PurePoll' is to be tested/proved. (==^) - :: HasConfiguration - => [PollAction] + :: [PollAction] -> [PollAction] -> Gen PollAction -> PollStateTestInfo @@ -235,8 +233,7 @@ property will cause it to fail. -} putDelBVState - :: HasConfiguration - => BlockVersion + :: BlockVersion -> Poll.BlockVersionState -> PollStateTestInfo -> Property @@ -247,8 +244,7 @@ putDelBVState bv bvs = in ([PutBVState bv bvs, DelBVState bv] ==^ []) actionPrefixGen setDeleteConfirmedSV - :: HasConfiguration - => SoftwareVersion + :: SoftwareVersion -> PollStateTestInfo -> Property setDeleteConfirmedSV sv = @@ -259,8 +255,7 @@ setDeleteConfirmedSV sv = in ([SetLastConfirmedSV sv, DelConfirmedSV appName] ==^ []) actionPrefixGen addDeleteConfirmedProposal - :: HasConfiguration - => Poll.ConfirmedProposalState + :: Poll.ConfirmedProposalState -> PollStateTestInfo -> Property addDeleteConfirmedProposal cps = @@ -272,8 +267,7 @@ addDeleteConfirmedProposal cps = []) actionPrefixGen insertDeleteProposal - :: HasConfiguration - => Poll.ProposalState + :: Poll.ProposalState -> PollStateTestInfo -> Property insertDeleteProposal ps = diff --git a/lrc/src/Pos/Lrc/DB/Leaders.hs b/lrc/src/Pos/Lrc/DB/Leaders.hs index 90ae4c4d912..97560d66ab8 100644 --- a/lrc/src/Pos/Lrc/DB/Leaders.hs +++ b/lrc/src/Pos/Lrc/DB/Leaders.hs @@ -19,9 +19,8 @@ module Pos.Lrc.DB.Leaders import Universum import Pos.Binary.Class (serialize') -import Pos.Core (EpochIndex, HasProtocolConstants, SlotCount, - SlotId (SlotId), SlotLeaders, StakeholderId, - flattenSlotId, unsafeMkLocalSlotIndex) +import Pos.Core (EpochIndex, SlotCount, SlotId (SlotId), SlotLeaders, + StakeholderId, flattenSlotId, unsafeMkLocalSlotIndex) import Pos.DB.Class (MonadDB, MonadDBRead) import Pos.Lrc.DB.Common (dbHasKey, getBi, putBatch, putBatchBi, putBi, toRocksOps) @@ -34,8 +33,8 @@ import Pos.Lrc.Genesis (genesisLeaders) getLeadersForEpoch :: MonadDBRead m => EpochIndex -> m (Maybe SlotLeaders) getLeadersForEpoch = getBi . leadersForEpochKey -getLeader :: MonadDBRead m => SlotId -> m (Maybe StakeholderId) -getLeader = getBi . leaderKey +getLeader :: MonadDBRead m => SlotCount -> SlotId -> m (Maybe StakeholderId) +getLeader epochSlots = getBi . leaderKey epochSlots ---------------------------------------------------------------------------- -- Operations @@ -45,10 +44,10 @@ getLeader = getBi . leaderKey -- The DB contains two mappings: -- * EpochIndex -> SlotLeaders -- * SlotId -> StakeholderId (added in CSE-240) -putLeadersForEpoch :: MonadDB m => EpochIndex -> SlotLeaders -> m () -putLeadersForEpoch epoch leaders = do +putLeadersForEpoch :: MonadDB m => SlotCount -> EpochIndex -> SlotLeaders -> m () +putLeadersForEpoch epochSlots epoch leaders = do let opsAllAtOnce = toRocksOps $ putLeadersForEpochAllAtOnceOps epoch leaders - opsSeparately = toRocksOps $ putLeadersForEpochSeparatelyOps epoch leaders + opsSeparately = toRocksOps $ putLeadersForEpochSeparatelyOps epochSlots epoch leaders putBatch $ opsAllAtOnce <> opsSeparately ---------------------------------------------------------------------------- @@ -63,7 +62,7 @@ prepareLrcLeaders epochSlots = if not hasLeadersForEpoch0 then -- The node is not initialized at all. Only need to put leaders -- for the first epoch. - putLeadersForEpoch 0 (genesisLeaders epochSlots) + putLeadersForEpoch epochSlots 0 (genesisLeaders epochSlots) else -- The node was initialized before CSE-240. -- Need to migrate data for all epochs. @@ -75,7 +74,7 @@ prepareLrcLeaders epochSlots = maybeLeaders <- getLeadersForEpoch i case maybeLeaders of Just leaders -> do - putBatchBi $ putLeadersForEpochSeparatelyOps i leaders + putBatchBi $ putLeadersForEpochSeparatelyOps epochSlots i leaders initLeaders (i + 1) Nothing -> pure () @@ -92,8 +91,8 @@ putInitFlag = putBi lrcDbLeadersInitFlag () leadersForEpochKey :: EpochIndex -> ByteString leadersForEpochKey = mappend "l/" . serialize' -leaderKey :: HasProtocolConstants => SlotId -> ByteString -leaderKey = mappend "ls/" . serialize' . flattenSlotId +leaderKey :: SlotCount -> SlotId -> ByteString +leaderKey epochSlots = mappend "ls/" . serialize' . flattenSlotId epochSlots lrcDbLeadersInitFlag :: ByteString lrcDbLeadersInitFlag = "linit/" @@ -113,15 +112,15 @@ putLeadersForEpochAllAtOnceOps epoch leaders = [(leadersForEpochKey epoch, leaders)] putLeadersForEpochSeparatelyOps - :: HasProtocolConstants - => EpochIndex + :: SlotCount + -> EpochIndex -> SlotLeaders -> [(ByteString, StakeholderId)] -putLeadersForEpochSeparatelyOps epoch leaders = - [(leaderKey $ mkSlotId epoch i, leader) +putLeadersForEpochSeparatelyOps epochSlots epoch leaders = + [(leaderKey epochSlots $ mkSlotId epoch i, leader) | (i, leader) <- zip [0..] $ toList leaders] where mkSlotId :: EpochIndex -> Word16 -> SlotId mkSlotId epoch' slot = -- Using @unsafeMkLocalSlotIndex@ because we trust the callers. - SlotId epoch' (unsafeMkLocalSlotIndex slot) + SlotId epoch' (unsafeMkLocalSlotIndex epochSlots slot) diff --git a/lrc/src/Pos/Lrc/Fts.hs b/lrc/src/Pos/Lrc/Fts.hs index 45586f732cd..8bc33e7e8b7 100644 --- a/lrc/src/Pos/Lrc/Fts.hs +++ b/lrc/src/Pos/Lrc/Fts.hs @@ -1,4 +1,3 @@ - -- | Base part of /follow-the-satoshi/ procedure. module Pos.Lrc.Fts @@ -226,7 +225,8 @@ previous upper bound (and thus it's more or equal to the current lower bound). -- specifies which addresses should count as “owning” funds for the purposes -- of follow-the-satoshi. followTheSatoshiM - :: forall m . (Monad m) + :: forall m + . Monad m => SlotCount -> SharedSeed -> Coin @@ -277,7 +277,8 @@ followTheSatoshiM epochSlots (SharedSeed seed) totalCoins = do -- testing this pure version as a proxy for the one above is insufficient. -- The monadic version needs to be tested in conjunction with the same conduit -- source that will feed it values in the real system. -followTheSatoshi :: SlotCount -> SharedSeed -> [(StakeholderId, Coin)] -> SlotLeaders +followTheSatoshi + :: SlotCount -> SharedSeed -> [(StakeholderId, Coin)] -> SlotLeaders followTheSatoshi epochSlots seed stakes | totalCoins > coinToInteger maxBound = error $ sformat diff --git a/lrc/src/Pos/Lrc/Genesis.hs b/lrc/src/Pos/Lrc/Genesis.hs index ef95b53f72a..2bff22a33aa 100644 --- a/lrc/src/Pos/Lrc/Genesis.hs +++ b/lrc/src/Pos/Lrc/Genesis.hs @@ -16,17 +16,14 @@ import Pos.Txp.Toil (GenesisUtxo (..), Utxo, utxoToStakes) -- | Compute leaders of the 0-th epoch from initial shared seed and stake distribution. -genesisLeaders :: (HasGenesisData) => SlotCount -> SlotLeaders -genesisLeaders epochSlots = followTheSatoshiUtxo epochSlots (gdFtsSeed genesisData) utxo +genesisLeaders :: HasGenesisData => SlotCount -> SlotLeaders +genesisLeaders epochSlots = + followTheSatoshiUtxo epochSlots (gdFtsSeed genesisData) utxo where GenesisUtxo utxo = genesisUtxo -- This should not be exported unless it is *needed* elsewhere -followTheSatoshiUtxo :: - (HasGenesisData) - => SlotCount - -> SharedSeed - -> Utxo - -> SlotLeaders +followTheSatoshiUtxo + :: HasGenesisData => SlotCount -> SharedSeed -> Utxo -> SlotLeaders followTheSatoshiUtxo epochSlots seed utxo = followTheSatoshi epochSlots seed $ HM.toList $ utxoToStakes utxo diff --git a/lrc/test/Test/Pos/Lrc/FtsSpec.hs b/lrc/test/Test/Pos/Lrc/FtsSpec.hs index da0fbf14dcb..12e04b00a4d 100644 --- a/lrc/test/Test/Pos/Lrc/FtsSpec.hs +++ b/lrc/test/Test/Pos/Lrc/FtsSpec.hs @@ -14,27 +14,23 @@ import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) import Test.QuickCheck (Arbitrary (..), Property, choose, infiniteListOf, suchThat, (===)) -import Pos.Core (BlockCount, Coin, SharedSeed, SlotCount, - StakeholderId, StakesList, addressHash, mkCoin, sumCoins, - unsafeAddCoin, unsafeIntegerToCoin) +import Pos.Core (Coin, ProtocolConstants (..), SharedSeed, SlotCount, + StakeholderId, StakesList, addressHash, mkCoin, + pcEpochSlots, sumCoins, unsafeAddCoin, + unsafeIntegerToCoin) import Pos.Crypto (PublicKey) import Pos.Lrc.Fts (followTheSatoshi) import Test.Pos.Core.Arbitrary () +import Test.Pos.Core.Dummy (dummyEpochSlots, dummyProtocolConstants) import Test.Pos.Util.QuickCheck.Property (qcNotElem) -blkSecurityParam :: BlockCount -blkSecurityParam = 2 - -epochSlots :: SlotCount -epochSlots = 20 - -- | Constant specifying the number of times 'ftsReasonableStake' will be -- run. numberOfRuns :: Int -- The higher is 'blkSecurityParam', the longer epochs will be and the more -- time FTS will take -numberOfRuns = 300000 `div` fromIntegral blkSecurityParam +numberOfRuns = 300000 `div` pcK dummyProtocolConstants spec :: Spec spec = do @@ -98,20 +94,27 @@ instance Arbitrary StakeAndHolder where stakesList = map addressHash (toList restPks) `zip` values return (myPk, stakesList) -ftsListLength :: SharedSeed -> StakeAndHolder -> Property +ftsListLength + :: SharedSeed + -> StakeAndHolder + -> Property ftsListLength seed (getNoStake -> (_, stakes)) = - length (followTheSatoshi epochSlots seed stakes) === fromIntegral epochSlots + length (followTheSatoshi dummyEpochSlots seed stakes) + === fromIntegral dummyEpochSlots -ftsNoStake :: SharedSeed -> StakeAndHolder -> Property +ftsNoStake + :: SharedSeed + -> StakeAndHolder + -> Property ftsNoStake seed (getNoStake -> (addressHash -> sId, stakes)) = - sId `qcNotElem` followTheSatoshi epochSlots seed stakes + sId `qcNotElem` followTheSatoshi dummyEpochSlots seed stakes -- It will be broken if 'Coin' is 0, but 'arbitrary' can't generate 0 -- for unknown reason. ftsAllStake :: SharedSeed -> PublicKey -> Coin -> Bool ftsAllStake seed pk v = let stakes = [(addressHash pk, v)] - in all (== addressHash pk) $ followTheSatoshi epochSlots seed stakes + in all (== addressHash pk) $ followTheSatoshi dummyEpochSlots seed stakes newtype FtsStream = Stream { getStream :: [SharedSeed] @@ -177,7 +180,7 @@ ftsReasonableStake stakeProbability threshold (getStream -> ftsList) (getSta / (1 - stakeProbability) newStakes :: [(StakeholderId, Coin)] newStakes = (addressHash pk, newStake) : stakes - picks = followTheSatoshi epochSlots seed newStakes + picks = followTheSatoshi dummyEpochSlots seed newStakes pLen = length picks newPresent = present + if stId `elem` picks then 1 / (fromIntegral numberOfRuns) else 0 diff --git a/node/Main.hs b/node/Main.hs index f50d051bd77..4f8aaab2174 100644 --- a/node/Main.hs +++ b/node/Main.hs @@ -18,6 +18,7 @@ import Pos.Binary () import Pos.Client.CLI (CommonNodeArgs (..), NodeArgs (..), SimpleNodeArgs (..)) import qualified Pos.Client.CLI as CLI +import Pos.Core (ProtocolConstants) import Pos.Crypto (ProtocolMagic) import Pos.Infra.Ntp.Configuration (NtpConfiguration) import Pos.Launcher (HasConfigurations, NodeParams (..), @@ -37,11 +38,12 @@ actionWithoutWallet , HasCompileInfo ) => ProtocolMagic + -> ProtocolConstants -> SscParams -> NodeParams -> Production () -actionWithoutWallet pm sscParams nodeParams = - Production $ runNodeReal pm nodeParams sscParams [updateTriggerWorker] +actionWithoutWallet pm pc sscParams nodeParams = + Production $ runNodeReal pm pc nodeParams sscParams [updateTriggerWorker] action :: ( HasConfigurations @@ -50,8 +52,9 @@ action => SimpleNodeArgs -> NtpConfiguration -> ProtocolMagic + -> ProtocolConstants -> Production () -action (SimpleNodeArgs (cArgs@CommonNodeArgs {..}) (nArgs@NodeArgs {..})) ntpConfig pm = do +action (SimpleNodeArgs (cArgs@CommonNodeArgs {..}) (nArgs@NodeArgs {..})) ntpConfig pm pc = do CLI.printInfoOnStart cArgs ntpConfig logInfo "Wallet is disabled, because software is built w/o it" currentParams <- CLI.getNodeParams loggerName cArgs nArgs @@ -59,7 +62,7 @@ action (SimpleNodeArgs (cArgs@CommonNodeArgs {..}) (nArgs@NodeArgs {..})) ntpCon let vssSK = fromJust $ npUserSecret currentParams ^. usVss let sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig currentParams) - actionWithoutWallet pm sscParams currentParams + actionWithoutWallet pm pc sscParams currentParams main :: IO () main = withCompileInfo $ do diff --git a/node/cardano-sl-node.cabal b/node/cardano-sl-node.cabal index 1be5cb3f837..e586af80b8b 100644 --- a/node/cardano-sl-node.cabal +++ b/node/cardano-sl-node.cabal @@ -17,6 +17,7 @@ executable cardano-node-simple main-is: Main.hs build-depends: base , cardano-sl-crypto + , cardano-sl-core , cardano-sl-ssc , cardano-sl-infra , cardano-sl-networking diff --git a/pkgs/default.nix b/pkgs/default.nix index bbfd98fadb8..141d6b53eed 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -15596,6 +15596,7 @@ license = stdenv.lib.licenses.mit; , cardano-sl , cardano-sl-block , cardano-sl-core +, cardano-sl-core-test , cardano-sl-crypto , cardano-sl-crypto-test , cardano-sl-db @@ -15672,6 +15673,7 @@ base bytestring cardano-sl cardano-sl-core +cardano-sl-core-test cardano-sl-crypto cardano-sl-crypto-test cardano-sl-db @@ -16482,6 +16484,7 @@ cardano-sl-binary-test cardano-sl-block cardano-sl-block-test cardano-sl-core +cardano-sl-core-test cardano-sl-crypto cardano-sl-txp cardano-sl-util @@ -16501,6 +16504,7 @@ cpphs benchmarkHaskellDepends = [ base cardano-sl +cardano-sl-core-test cardano-sl-txp cardano-sl-txp-test criterion @@ -16527,6 +16531,7 @@ license = stdenv.lib.licenses.mit; , cardano-sl-block-test , cardano-sl-client , cardano-sl-core +, cardano-sl-core-test , cardano-sl-crypto , cardano-sl-crypto-test , cardano-sl-db @@ -16583,6 +16588,7 @@ cardano-sl cardano-sl-block cardano-sl-client cardano-sl-core +cardano-sl-core-test cardano-sl-crypto cardano-sl-crypto-test cardano-sl-db @@ -16628,6 +16634,7 @@ cardano-sl-binary cardano-sl-block cardano-sl-block-test cardano-sl-core +cardano-sl-core-test cardano-sl-crypto cardano-sl-crypto-test cardano-sl-db @@ -17124,6 +17131,7 @@ license = stdenv.lib.licenses.mit; mkDerivation , base , cardano-sl +, cardano-sl-core , cardano-sl-crypto , cardano-sl-infra , cardano-sl-networking @@ -17149,6 +17157,7 @@ isExecutable = true; executableHaskellDepends = [ base cardano-sl +cardano-sl-core cardano-sl-crypto cardano-sl-infra cardano-sl-networking @@ -18132,6 +18141,7 @@ cardano-sl cardano-sl-block cardano-sl-client cardano-sl-core +cardano-sl-core-test cardano-sl-crypto cardano-sl-db cardano-sl-delegation @@ -18269,6 +18279,7 @@ license = stdenv.lib.licenses.mit; , cardano-sl-core , cardano-sl-core-test , cardano-sl-crypto +, cardano-sl-crypto-test , cardano-sl-db , cardano-sl-delegation , cardano-sl-infra @@ -18492,7 +18503,9 @@ cardano-sl cardano-sl-block cardano-sl-client cardano-sl-core +cardano-sl-core-test cardano-sl-crypto +cardano-sl-crypto-test cardano-sl-db cardano-sl-delegation cardano-sl-lrc diff --git a/ssc/Pos/Arbitrary/Ssc.hs b/ssc/Pos/Arbitrary/Ssc.hs index 39bab7afbcd..f3be425587d 100644 --- a/ssc/Pos/Arbitrary/Ssc.hs +++ b/ssc/Pos/Arbitrary/Ssc.hs @@ -29,8 +29,6 @@ import Pos.Binary.Ssc () import Pos.Core (EpochIndex, SlotId (..), VssCertificate (..), VssCertificatesMap, mkVssCertificate, mkVssCertificatesMapLossy) -import Pos.Core.Configuration (HasProtocolConstants, - protocolConstants) import Pos.Core.ProtocolConstants (ProtocolConstants (..), VssMaxTTL (..), VssMinTTL (..)) import Pos.Core.Ssc (Commitment (..), CommitmentsMap, Opening (..), @@ -39,8 +37,8 @@ import Pos.Core.Ssc (Commitment (..), CommitmentsMap, Opening (..), import Pos.Crypto (ProtocolMagic, SecretKey, deterministic, randomNumberInRange, toVssPublicKey, vssKeyGen) import Pos.Infra.Communication.Types.Relay (DataMsg (..)) -import Pos.Ssc.Base (isCommitmentIdExplicit, isOpeningIdExplicit, - isSharesIdExplicit, mkSignedCommitment) +import Pos.Ssc.Base (isCommitmentId, isOpeningId, isSharesId, + mkSignedCommitment) import Pos.Ssc.Message (MCCommitment (..), MCOpening (..), MCShares (..), MCVssCertificate (..), SscTag (..)) import Pos.Ssc.Toss.Types (TossModifier (..)) @@ -49,6 +47,7 @@ import Pos.Ssc.VssCertData (VssCertData (..)) import Test.Pos.Core.Arbitrary (genVssCertificate) import Test.Pos.Core.Arbitrary.Unsafe () +import Test.Pos.Core.Dummy (dummyK) import Test.Pos.Crypto.Arbitrary (genSignature) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Arbitrary (Nonrepeating (..), @@ -180,13 +179,13 @@ instance Arbitrary SscPayload where shrink = genericShrink -- | We need the 'ProtocolConstants' because they give meaning to 'SlotId'. -genSscPayloadForSlot :: ProtocolMagic -> ProtocolConstants -> SlotId -> Gen SscPayload -genSscPayloadForSlot pm pc slot - | isCommitmentIdExplicit pc slot = +genSscPayloadForSlot :: ProtocolMagic -> SlotId -> Gen SscPayload +genSscPayloadForSlot pm slot + | isCommitmentId dummyK slot = CommitmentsPayload <$> (genCommitments slot) <*> (genVssCerts slot) - | isOpeningIdExplicit pc slot = + | isOpeningId dummyK slot = OpeningsPayload <$> arbitrary <*> (genVssCerts slot) - | isSharesIdExplicit pc slot = + | isSharesId dummyK slot = SharesPayload <$> arbitrary <*> (genVssCerts slot) | otherwise = CertificatesPayload <$> (genVssCerts slot) @@ -203,8 +202,8 @@ genSscPayloadForSlot pm pc slot arbitrary genValidCert SlotId{..} (sk, pk) = mkVssCertificate pm sk pk $ siEpoch + 5 -instance HasProtocolConstants => Arbitrary SscPayloadDependsOnSlot where - arbitrary = pure $ SscPayloadDependsOnSlot (genSscPayloadForSlot dummyProtocolMagic protocolConstants) +instance Arbitrary SscPayloadDependsOnSlot where + arbitrary = pure $ SscPayloadDependsOnSlot (genSscPayloadForSlot dummyProtocolMagic) genVssCertificatesMap :: ProtocolMagic -> Gen VssCertificatesMap genVssCertificatesMap pm = do @@ -215,11 +214,11 @@ instance Arbitrary VssCertificatesMap where arbitrary = genVssCertificatesMap dummyProtocolMagic shrink = genericShrink -instance HasProtocolConstants => Arbitrary VssCertData where +instance Arbitrary VssCertData where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary SscGlobalState where +instance Arbitrary SscGlobalState where arbitrary = genericArbitrary shrink = genericShrink diff --git a/ssc/Pos/Ssc/Base.hs b/ssc/Pos/Ssc/Base.hs index 9a665c372a4..4bafc10b900 100644 --- a/ssc/Pos/Ssc/Base.hs +++ b/ssc/Pos/Ssc/Base.hs @@ -5,17 +5,11 @@ module Pos.Ssc.Base ( -- * Helpers - isCommitmentIdExplicit - , isCommitmentId - , isCommitmentIdxExplicit + isCommitmentId , isCommitmentIdx - , isOpeningIdExplicit , isOpeningId - , isOpeningIdxExplicit , isOpeningIdx - , isSharesIdExplicit , isSharesId - , isSharesIdxExplicit , isSharesIdx , mkSignedCommitment , secretToSharedSeed @@ -48,14 +42,12 @@ import Serokell.Data.Memory.Units (Byte) import Serokell.Util (VerificationRes, verifyGeneric) import Pos.Binary.Class (biSize, fromBinary) -import Pos.Core (EpochIndex (..), LocalSlotIndex, SharedSeed (..), - SlotCount, SlotId (..), StakeholderId, addressHash, - unsafeMkLocalSlotIndexExplicit) -import Pos.Core.Configuration (HasProtocolConstants, - protocolConstants, vssMaxTTL, vssMinTTL) +import Pos.Core (BlockCount, EpochIndex (..), LocalSlotIndex, + SharedSeed (..), SlotCount, SlotId (..), StakeholderId, + addressHash, unsafeMkLocalSlotIndex, vssMaxTTL, vssMinTTL) import Pos.Core.Limits (stripHashMap) import Pos.Core.ProtocolConstants (ProtocolConstants (..), - pcSlotSecurityParam) + kEpochSlots, kSlotSecurityParam) import Pos.Core.Ssc (Commitment (..), CommitmentsMap (getCommitmentsMap), Opening (..), SignedCommitment, SscPayload (..), @@ -83,50 +75,36 @@ mkSignedCommitment :: ProtocolMagic -> SecretKey -> EpochIndex -> Commitment -> SignedCommitment mkSignedCommitment pm sk i c = (toPublic sk, c, sign pm SignCommitment sk (i, c)) -toLocalSlotIndex :: ProtocolConstants -> SlotCount -> LocalSlotIndex -toLocalSlotIndex pc = unsafeMkLocalSlotIndexExplicit pc . fromIntegral +toLocalSlotIndex :: SlotCount -> SlotCount -> LocalSlotIndex +toLocalSlotIndex epochSlots = unsafeMkLocalSlotIndex epochSlots . fromIntegral -isCommitmentIdxExplicit :: ProtocolConstants -> LocalSlotIndex -> Bool -isCommitmentIdxExplicit pc = - inRange (toLocalSlotIndex pc 0, - toLocalSlotIndex pc (pcSlotSecurityParam pc - 1)) +inLocalSlotIndexRange + :: SlotCount -> (SlotCount, SlotCount) -> LocalSlotIndex -> Bool +inLocalSlotIndexRange epochSlots (lo, hi) = + inRange (toLocalSlotIndex epochSlots lo, toLocalSlotIndex epochSlots hi) -isCommitmentIdx :: HasProtocolConstants => LocalSlotIndex -> Bool -isCommitmentIdx = isCommitmentIdxExplicit protocolConstants +isCommitmentIdx :: BlockCount -> LocalSlotIndex -> Bool +isCommitmentIdx k = + inLocalSlotIndexRange (kEpochSlots k) (0, kSlotSecurityParam k - 1) -isOpeningIdxExplicit :: ProtocolConstants -> LocalSlotIndex -> Bool -isOpeningIdxExplicit pc = - inRange (toLocalSlotIndex pc (2 * pcSlotSecurityParam pc), - toLocalSlotIndex pc (3 * pcSlotSecurityParam pc - 1)) +isOpeningIdx :: BlockCount -> LocalSlotIndex -> Bool +isOpeningIdx k = inLocalSlotIndexRange + (kEpochSlots k) + (2 * kSlotSecurityParam k, 3 * kSlotSecurityParam k - 1) -isOpeningIdx :: HasProtocolConstants => LocalSlotIndex -> Bool -isOpeningIdx = isOpeningIdxExplicit protocolConstants +isSharesIdx :: BlockCount -> LocalSlotIndex -> Bool +isSharesIdx k = inLocalSlotIndexRange + (kEpochSlots k) + (4 * kSlotSecurityParam k, 5 * kSlotSecurityParam k - 1) -isSharesIdxExplicit :: ProtocolConstants -> LocalSlotIndex -> Bool -isSharesIdxExplicit pc = - inRange (toLocalSlotIndex pc (4 * pcSlotSecurityParam pc), - toLocalSlotIndex pc (5 * pcSlotSecurityParam pc - 1)) +isCommitmentId :: BlockCount -> SlotId -> Bool +isCommitmentId k = isCommitmentIdx k . siSlot -isSharesIdx :: HasProtocolConstants => LocalSlotIndex -> Bool -isSharesIdx = isSharesIdxExplicit protocolConstants +isOpeningId :: BlockCount -> SlotId -> Bool +isOpeningId k = isOpeningIdx k . siSlot -isCommitmentIdExplicit :: ProtocolConstants -> SlotId -> Bool -isCommitmentIdExplicit pc = isCommitmentIdxExplicit pc . siSlot - -isCommitmentId :: HasProtocolConstants => SlotId -> Bool -isCommitmentId = isCommitmentIdExplicit protocolConstants - -isOpeningIdExplicit :: ProtocolConstants -> SlotId -> Bool -isOpeningIdExplicit pc = isOpeningIdxExplicit pc . siSlot - -isOpeningId :: HasProtocolConstants => SlotId -> Bool -isOpeningId = isOpeningIdExplicit protocolConstants - -isSharesIdExplicit :: ProtocolConstants -> SlotId -> Bool -isSharesIdExplicit pc = isSharesIdxExplicit pc . siSlot - -isSharesId :: HasProtocolConstants => SlotId -> Bool -isSharesId = isSharesIdExplicit protocolConstants +isSharesId :: BlockCount -> SlotId -> Bool +isSharesId k = isSharesIdx k . siSlot ---------------------------------------------------------------------------- -- CommitmentsMap @@ -225,10 +203,10 @@ verifyOpening Commitment {..} (Opening secret) = fromMaybe False $ -- CHECK: @checkCertTTL -- | Check that the VSS certificate has valid TTL: i. e. it is in -- '[vssMinTTL, vssMaxTTL]'. -checkCertTTL :: HasProtocolConstants => EpochIndex -> VssCertificate -> Bool -checkCertTTL curEpochIndex vc = - expiryEpoch + 1 >= vssMinTTL + curEpochIndex && - expiryEpoch < vssMaxTTL + curEpochIndex +checkCertTTL :: ProtocolConstants -> EpochIndex -> VssCertificate -> Bool +checkCertTTL pc curEpochIndex vc = + expiryEpoch + 1 >= vssMinTTL pc + curEpochIndex && + expiryEpoch < vssMaxTTL pc + curEpochIndex where expiryEpoch = vcExpiryEpoch vc @@ -266,9 +244,9 @@ stripSscPayload lim payload = case payload of getVssCertificatesMap -- | Default SSC payload depending on local slot index. -defaultSscPayload :: HasProtocolConstants => LocalSlotIndex -> SscPayload -defaultSscPayload lsi - | isCommitmentIdx lsi = CommitmentsPayload mempty mempty - | isOpeningIdx lsi = OpeningsPayload mempty mempty - | isSharesIdx lsi = SharesPayload mempty mempty +defaultSscPayload :: BlockCount -> LocalSlotIndex -> SscPayload +defaultSscPayload k lsi + | isCommitmentIdx k lsi = CommitmentsPayload mempty mempty + | isOpeningIdx k lsi = OpeningsPayload mempty mempty + | isSharesIdx k lsi = SharesPayload mempty mempty | otherwise = CertificatesPayload mempty diff --git a/ssc/Pos/Ssc/Functions.hs b/ssc/Pos/Ssc/Functions.hs index a386ee0523d..091c114575f 100644 --- a/ssc/Pos/Ssc/Functions.hs +++ b/ssc/Pos/Ssc/Functions.hs @@ -21,10 +21,10 @@ import Control.Monad.Except (MonadError (throwError)) import qualified Data.HashMap.Strict as HM import Serokell.Util.Verify (isVerSuccess) -import Pos.Core (EpochIndex (..), HasGenesisData, - HasProtocolConstants, IsMainHeader, SlotId (..), +import Pos.Core (BlockCount, EpochIndex (..), HasGenesisData, + IsMainHeader, ProtocolConstants, SlotId (..), StakeholderId, VssCertificatesMap, genesisVssCerts, - headerSlotL) + headerSlotL, pcBlkSecurityParam) import Pos.Core.Slotting (crucialSlot) import Pos.Core.Ssc (CommitmentsMap (getCommitmentsMap), SscPayload (..)) @@ -70,9 +70,13 @@ hasVssCertificate id = VCD.member id . _sgsVssCertificates -- -- We also do some general sanity checks. verifySscPayload - :: (MonadError SscVerifyError m, HasProtocolConstants) - => ProtocolMagic -> Either EpochIndex (Some IsMainHeader) -> SscPayload -> m () -verifySscPayload pm eoh payload = case payload of + :: MonadError SscVerifyError m + => ProtocolMagic + -> ProtocolConstants + -> Either EpochIndex (Some IsMainHeader) + -> SscPayload + -> m () +verifySscPayload pm pc eoh payload = case payload of CommitmentsPayload comms certs -> do whenHeader eoh isComm commChecks comms @@ -91,11 +95,12 @@ verifySscPayload pm eoh payload = case payload of whenHeader (Right header) f = f $ header ^. headerSlotL epochId = either identity (view $ headerSlotL . to siEpoch) eoh - isComm slotId = unless (isCommitmentId slotId) $ throwError $ NotCommitmentPhase slotId - isOpen slotId = unless (isOpeningId slotId) $ throwError $ NotOpeningPhase slotId - isShare slotId = unless (isSharesId slotId) $ throwError $ NotSharesPhase slotId + k = pcBlkSecurityParam pc + isComm slotId = unless (isCommitmentId k slotId) $ throwError $ NotCommitmentPhase slotId + isOpen slotId = unless (isOpeningId k slotId) $ throwError $ NotOpeningPhase slotId + isShare slotId = unless (isSharesId k slotId) $ throwError $ NotSharesPhase slotId isOther slotId = unless (all not $ - map ($ slotId) [isCommitmentId, isOpeningId, isSharesId]) $ + map ($ slotId) [isCommitmentId k, isOpeningId k, isSharesId k]) $ throwError $ NotIntermediatePhase slotId -- We *forbid* blocks from having commitments/openings/shares in blocks @@ -125,15 +130,19 @@ verifySscPayload pm eoh payload = case payload of -- #checkCert certsChecks certs = verifyEntriesGuardM identity identity CertificateInvalidTTL - (pure . checkCertTTL epochId) + (pure . checkCertTTL pc epochId) (toList certs) ---------------------------------------------------------------------------- -- Modern ---------------------------------------------------------------------------- -getStableCertsPure :: (HasProtocolConstants, HasGenesisData) => EpochIndex -> VCD.VssCertData -> VssCertificatesMap -getStableCertsPure epoch certs +getStableCertsPure + :: HasGenesisData + => BlockCount + -> EpochIndex + -> VCD.VssCertData + -> VssCertificatesMap +getStableCertsPure k epoch certs | epoch == 0 = genesisVssCerts - | otherwise = - VCD.certs $ VCD.setLastKnownSlot (crucialSlot epoch) certs + | otherwise = VCD.certs $ VCD.setLastKnownSlot (crucialSlot k epoch) certs diff --git a/ssc/Pos/Ssc/Logic/Local.hs b/ssc/Pos/Ssc/Logic/Local.hs index b2c46c8155e..f88ae4c091c 100644 --- a/ssc/Pos/Ssc/Logic/Local.hs +++ b/ssc/Pos/Ssc/Logic/Local.hs @@ -29,10 +29,11 @@ import System.Wlog (WithLogger, launchNamedPureLog, logWarning) import Pos.Binary.Class (biSize) import Pos.Binary.Ssc () -import Pos.Core (BlockVersionData (..), EpochIndex, HasGenesisData, - HasProtocolConstants, SlotId (..), StakeholderId, - VssCertificate, epochIndexL, - mkVssCertificatesMapSingleton) +import Pos.Core (BlockCount, BlockVersionData (..), EpochIndex, + HasGenesisData, ProtocolConstants, SlotId (..), + StakeholderId, VssCertificate, epochIndexL, kEpochSlots, + mkVssCertificatesMapSingleton, pcBlkSecurityParam, + pcEpochSlots) import Pos.Core.Ssc (InnerSharesMap, Opening, SignedCommitment, SscPayload (..), mkCommitmentsMap) import Pos.Crypto (ProtocolMagic) @@ -63,15 +64,15 @@ import Pos.Ssc.Types (SscGlobalState, SscLocalData (..), ldEpoch, -- 'SlotId'. If payload for given 'SlotId' can't be constructed, -- empty payload can be returned. sscGetLocalPayload - :: forall ctx m. - (MonadIO m, MonadSscMem ctx m, WithLogger m, HasProtocolConstants) - => SlotId -> m SscPayload -sscGetLocalPayload = sscRunLocalQuery . sscGetLocalPayloadQ + :: forall ctx m + . (MonadIO m, MonadSscMem ctx m, WithLogger m) + => BlockCount + -> SlotId + -> m SscPayload +sscGetLocalPayload k = sscRunLocalQuery . sscGetLocalPayloadQ k -sscGetLocalPayloadQ - :: (HasProtocolConstants) - => SlotId -> SscLocalQuery SscPayload -sscGetLocalPayloadQ SlotId {..} = do +sscGetLocalPayloadQ :: BlockCount -> SlotId -> SscLocalQuery SscPayload +sscGetLocalPayloadQ k SlotId {..} = do expectedEpoch <- view ldEpoch let warningMsg = sformat warningFmt siEpoch expectedEpoch isExpected <- @@ -83,9 +84,9 @@ sscGetLocalPayloadQ SlotId {..} = do warningFmt = "sscGetLocalPayloadQ: unexpected epoch ("%int% ", stored one is "%int%")" getPayload True - | isCommitmentIdx siSlot = CommitmentsPayload <$> view tmCommitments - | isOpeningIdx siSlot = OpeningsPayload <$> view tmOpenings - | isSharesIdx siSlot = SharesPayload <$> view tmShares + | isCommitmentIdx k siSlot = CommitmentsPayload <$> view tmCommitments + | isOpeningIdx k siSlot = OpeningsPayload <$> view tmOpenings + | isSharesIdx k siSlot = SharesPayload <$> view tmShares getPayload _ = pure CertificatesPayload getCertificates isExpected | isExpected = view tmCertificates @@ -95,8 +96,8 @@ sscGetLocalPayloadQ SlotId {..} = do -- best known chain. This function is assumed to be called after applying -- block and before releasing lock on block application. sscNormalize - :: forall ctx m. - ( MonadGState m + :: forall ctx m + . ( MonadGState m , MonadBlockDBRead m , MonadSscMem ctx m , HasLrcContext ctx @@ -104,8 +105,10 @@ sscNormalize , MonadIO m , Rand.MonadRandom m ) - => ProtocolMagic -> m () -sscNormalize pm = do + => ProtocolMagic + -> ProtocolConstants + -> m () +sscNormalize pm pc = do tipEpoch <- view epochIndexL <$> getTipHeader richmenData <- getSscRichmen "sscNormalize" tipEpoch bvd <- gsAdoptedBVData @@ -117,24 +120,25 @@ sscNormalize pm = do launchNamedPureLog atomically $ syncingStateWith localVar $ executeMonadBaseRandom seed $ - sscNormalizeU pm (tipEpoch, richmenData) bvd gs + sscNormalizeU pm pc (tipEpoch, richmenData) bvd gs where -- (... MonadPseudoRandom) a -> (... n) a executeMonadBaseRandom seed = hoist $ hoist (pure . fst . Rand.withDRG seed) sscNormalizeU - :: (HasProtocolConstants, HasGenesisData) + :: HasGenesisData => ProtocolMagic + -> ProtocolConstants -> (EpochIndex, RichmenStakes) -> BlockVersionData -> SscGlobalState -> SscLocalUpdate () -sscNormalizeU pm (epoch, stake) bvd gs = do +sscNormalizeU pm pc (epoch, stake) bvd gs = do oldModifier <- use ldModifier let multiRichmen = HM.fromList [(epoch, stake)] newModifier <- evalPureTossWithLogger gs $ supplyPureTossEnv (multiRichmen, bvd) $ - execTossT mempty $ normalizeToss pm epoch oldModifier + execTossT mempty $ normalizeToss pm pc epoch oldModifier ldModifier .= newModifier ldEpoch .= epoch ldSize .= biSize newModifier @@ -151,12 +155,14 @@ sscIsDataUseful , MonadSscMem ctx m , Rand.MonadRandom m , HasGenesisData - , HasProtocolConstants ) - => SscTag -> StakeholderId -> m Bool -sscIsDataUseful tag id = + => BlockCount + -> SscTag + -> StakeholderId + -> m Bool +sscIsDataUseful k tag id = ifM - (maybe False (isGoodSlotForTag tag . siSlot) <$> getCurrentSlot) + (maybe False (isGoodSlotForTag k tag . siSlot) <$> getCurrentSlot (kEpochSlots k)) (evalTossInMem $ sscIsDataUsefulDo tag) (pure False) where @@ -197,10 +203,11 @@ type SscDataProcessingMode ctx m = sscProcessCommitment :: SscDataProcessingMode ctx m => ProtocolMagic + -> ProtocolConstants -> SignedCommitment -> m (Either SscVerifyError ()) -sscProcessCommitment pm comm = - sscProcessData pm CommitmentMsg +sscProcessCommitment pm pc comm = + sscProcessData pm pc CommitmentMsg $ CommitmentsPayload (mkCommitmentsMap [comm]) mempty -- | Process 'Opening' received from network, checking it against @@ -208,10 +215,11 @@ sscProcessCommitment pm comm = sscProcessOpening :: SscDataProcessingMode ctx m => ProtocolMagic + -> ProtocolConstants -> StakeholderId -> Opening -> m (Either SscVerifyError ()) -sscProcessOpening pm id opening = sscProcessData pm OpeningMsg +sscProcessOpening pm pc id opening = sscProcessData pm pc OpeningMsg $ OpeningsPayload (HM.fromList [(id, opening)]) mempty -- | Process 'InnerSharesMap' received from network, checking it against @@ -219,31 +227,34 @@ sscProcessOpening pm id opening = sscProcessData pm OpeningMsg sscProcessShares :: SscDataProcessingMode ctx m => ProtocolMagic + -> ProtocolConstants -> StakeholderId -> InnerSharesMap -> m (Either SscVerifyError ()) -sscProcessShares pm id shares = - sscProcessData pm SharesMsg $ SharesPayload (HM.fromList [(id, shares)]) mempty +sscProcessShares pm pc id shares = + sscProcessData pm pc SharesMsg $ SharesPayload (HM.fromList [(id, shares)]) mempty -- | Process 'VssCertificate' received from network, checking it against -- current state (global + local) and adding to local state if it's valid. sscProcessCertificate :: SscDataProcessingMode ctx m => ProtocolMagic + -> ProtocolConstants -> VssCertificate -> m (Either SscVerifyError ()) -sscProcessCertificate pm cert = sscProcessData pm VssCertificateMsg +sscProcessCertificate pm pc cert = sscProcessData pm pc VssCertificateMsg $ CertificatesPayload (mkVssCertificatesMapSingleton cert) sscProcessData :: SscDataProcessingMode ctx m => ProtocolMagic + -> ProtocolConstants -> SscTag -> SscPayload -> m (Either SscVerifyError ()) -sscProcessData pm tag payload = +sscProcessData pm pc tag payload = runExceptT $ do - getCurrentSlot >>= checkSlot + getCurrentSlot (pcEpochSlots pc) >>= checkSlot ld <- sscRunLocalQuery ask bvd <- gsAdoptedBVData let epoch = ld ^. ldEpoch @@ -255,11 +266,11 @@ sscProcessData pm tag payload = ExceptT $ sscRunLocalSTM $ executeMonadBaseRandom seed $ - sscProcessDataDo pm (epoch, richmen) bvd gs payload + sscProcessDataDo pm pc (epoch, richmen) bvd gs payload where checkSlot Nothing = throwError CurrentSlotUnknown checkSlot (Just si@SlotId {..}) - | isGoodSlotForTag tag siSlot = pass + | isGoodSlotForTag (pcBlkSecurityParam pc) tag siSlot = pass | CommitmentMsg <- tag = throwError $ NotCommitmentPhase si | OpeningMsg <- tag = throwError $ NotOpeningPhase si | SharesMsg <- tag = throwError $ NotSharesPhase si @@ -268,15 +279,19 @@ sscProcessData pm tag payload = executeMonadBaseRandom seed = hoist $ hoist (pure . fst . Rand.withDRG seed) sscProcessDataDo - :: (MonadState SscLocalData m, HasGenesisData - , WithLogger m, Rand.MonadRandom m, HasProtocolConstants) + :: ( MonadState SscLocalData m + , HasGenesisData + , WithLogger m + , Rand.MonadRandom m + ) => ProtocolMagic + -> ProtocolConstants -> (EpochIndex, RichmenStakes) -> BlockVersionData -> SscGlobalState -> SscPayload -> m (Either SscVerifyError ()) -sscProcessDataDo pm richmenData bvd gs payload = +sscProcessDataDo pm pc richmenData bvd gs payload = runExceptT $ do storedEpoch <- use ldEpoch let givenEpoch = fst richmenData @@ -293,14 +308,15 @@ sscProcessDataDo pm richmenData bvd gs payload = | otherwise -> evalPureTossWithLogger gs . supplyPureTossEnv (multiRichmen, bvd) . - execTossT mempty . refreshToss pm givenEpoch =<< + execTossT mempty . refreshToss pm pc givenEpoch =<< use ldModifier newTM <- ExceptT $ evalPureTossWithLogger gs $ supplyPureTossEnv (multiRichmen, bvd) $ runExceptT $ - execTossT oldTM $ verifyAndApplySscPayload pm (Left storedEpoch) payload + execTossT oldTM $ + verifyAndApplySscPayload pm pc (Left storedEpoch) payload ldModifier .= newTM -- If mempool was exhausted, it's easier to recompute total size. -- Otherwise (most common case) we don't want to spend time on it and diff --git a/ssc/Pos/Ssc/Logic/VAR.hs b/ssc/Pos/Ssc/Logic/VAR.hs index 372f7a2781c..dfba8c371e5 100644 --- a/ssc/Pos/Ssc/Logic/VAR.hs +++ b/ssc/Pos/Ssc/Logic/VAR.hs @@ -22,9 +22,9 @@ import Universum import Pos.Binary.Ssc () import Pos.Core (BlockVersionData, ComponentBlock (..), - HasCoreConfiguration, HasGenesisData, - HasProtocolConstants, HeaderHash, epochIndexL, - epochOrSlotG, headerHash) + HasCoreConfiguration, HasGenesisData, HeaderHash, + ProtocolConstants, SlotCount, epochIndexL, epochOrSlotG, + headerHash) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Ssc (SscPayload (..)) import Pos.Crypto (ProtocolMagic) @@ -80,9 +80,10 @@ type SscGlobalApplyMode ctx m = SscGlobalVerifyMode ctx m sscVerifyBlocks :: SscGlobalVerifyMode ctx m => ProtocolMagic + -> ProtocolConstants -> OldestFirst NE SscBlock -> m (Either SscVerifyError SscGlobalState) -sscVerifyBlocks pm blocks = do +sscVerifyBlocks pm pc blocks = do let epoch = blocks ^. _Wrapped . _neHead . epochIndexL let lastEpoch = blocks ^. _Wrapped . _neLast . epochIndexL let differentEpochsMsg = @@ -98,7 +99,7 @@ sscVerifyBlocks pm blocks = do gs <- atomically $ readTVar globalVar res <- runExceptT - (execStateT (sscVerifyAndApplyBlocks pm richmenSet bvd blocks) gs) + (execStateT (sscVerifyAndApplyBlocks pm pc richmenSet bvd blocks) gs) case res of Left e | sscIsCriticalVerifyError e -> @@ -116,18 +117,19 @@ sscVerifyBlocks pm blocks = do sscApplyBlocks :: SscGlobalApplyMode ctx m => ProtocolMagic + -> ProtocolConstants -> OldestFirst NE SscBlock -> Maybe SscGlobalState -> m [SomeBatchOp] -sscApplyBlocks pm blocks (Just newState) = do - inAssertMode $ do - let hashes = map headerHash blocks - expectedState <- sscVerifyValidBlocks pm blocks - if | newState == expectedState -> pass - | otherwise -> onUnexpectedVerify hashes - sscApplyBlocksFinish newState -sscApplyBlocks pm blocks Nothing = - sscApplyBlocksFinish =<< sscVerifyValidBlocks pm blocks +sscApplyBlocks pm pc blocks = \case + Just newState -> do + inAssertMode $ do + let hashes = map headerHash blocks + expectedState <- sscVerifyValidBlocks pm pc blocks + if | newState == expectedState -> pass + | otherwise -> onUnexpectedVerify hashes + sscApplyBlocksFinish newState + Nothing -> sscApplyBlocksFinish =<< sscVerifyValidBlocks pm pc blocks sscApplyBlocksFinish :: (SscGlobalApplyMode ctx m) @@ -142,10 +144,11 @@ sscApplyBlocksFinish gs = do sscVerifyValidBlocks :: SscGlobalApplyMode ctx m => ProtocolMagic + -> ProtocolConstants -> OldestFirst NE SscBlock -> m SscGlobalState -sscVerifyValidBlocks pm blocks = - sscVerifyBlocks pm blocks >>= \case +sscVerifyValidBlocks pm pc blocks = + sscVerifyBlocks pm pc blocks >>= \case Left e -> onVerifyFailedInApply hashes e Right newState -> return newState where @@ -179,32 +182,34 @@ onVerifyFailedInApply hashes e = assertionFailed msg -- | Verify SSC-related part of given blocks with respect to current GState -- and apply them on success. Blocks must be from the same epoch. sscVerifyAndApplyBlocks - :: (SscVerifyMode m, HasProtocolConstants, HasGenesisData) + :: (SscVerifyMode m, HasGenesisData) => ProtocolMagic + -> ProtocolConstants -> RichmenStakes -> BlockVersionData -> OldestFirst NE SscBlock -> m () -sscVerifyAndApplyBlocks pm richmenStake bvd blocks = - verifyAndApplyMultiRichmen pm False (richmenData, bvd) blocks +sscVerifyAndApplyBlocks pm pc richmenStake bvd blocks = + verifyAndApplyMultiRichmen pm pc False (richmenData, bvd) blocks where epoch = blocks ^. _Wrapped . _neHead . epochIndexL richmenData = HM.fromList [(epoch, richmenStake)] verifyAndApplyMultiRichmen - :: (SscVerifyMode m, HasProtocolConstants, HasGenesisData) + :: (SscVerifyMode m, HasGenesisData) => ProtocolMagic + -> ProtocolConstants -> Bool -> (MultiRichmenStakes, BlockVersionData) -> OldestFirst NE SscBlock -> m () -verifyAndApplyMultiRichmen pm onlyCerts env = +verifyAndApplyMultiRichmen pm pc onlyCerts env = tossToVerifier . hoist (supplyPureTossEnv env) . mapM_ verifyAndApplyDo where verifyAndApplyDo (ComponentBlockGenesis header) = applyGenesisBlock $ header ^. epochIndexL verifyAndApplyDo (ComponentBlockMain header payload) = - verifyAndApplySscPayload pm (Right header) $ + verifyAndApplySscPayload pm pc (Right header) $ filterPayload payload filterPayload payload | onlyCerts = leaveOnlyCerts payload @@ -223,15 +228,19 @@ verifyAndApplyMultiRichmen pm onlyCerts env = -- happen if these blocks haven't been applied before. sscRollbackBlocks :: SscGlobalApplyMode ctx m - => NewestFirst NE SscBlock -> m [SomeBatchOp] -sscRollbackBlocks blocks = sscRunGlobalUpdate $ do - sscRollbackU blocks + => SlotCount + -> NewestFirst NE SscBlock + -> m [SomeBatchOp] +sscRollbackBlocks epochSlots blocks = sscRunGlobalUpdate $ do + sscRollbackU epochSlots blocks sscGlobalStateToBatch <$> get sscRollbackU - :: (HasProtocolConstants, HasGenesisData) - => NewestFirst NE SscBlock -> SscGlobalUpdate () -sscRollbackU blocks = tossToUpdate $ rollbackSsc oldestEOS payloads + :: HasGenesisData + => SlotCount + -> NewestFirst NE SscBlock + -> SscGlobalUpdate () +sscRollbackU epochSlots blocks = tossToUpdate $ rollbackSsc epochSlots oldestEOS payloads where oldestEOS = blocks ^. _Wrapped . _neLast . epochOrSlotG payloads = NewestFirst $ mapMaybe extractPayload $ toList blocks diff --git a/ssc/Pos/Ssc/State.hs b/ssc/Pos/Ssc/State.hs index e9072489816..c50dc94b09b 100644 --- a/ssc/Pos/Ssc/State.hs +++ b/ssc/Pos/Ssc/State.hs @@ -11,6 +11,7 @@ import Universum import qualified Control.Concurrent.STM as STM import System.Wlog (WithLogger) +import Pos.Core (SlotCount) import Pos.DB (MonadDBRead) import Pos.Infra.Slotting.Class (MonadSlots) import Pos.Ssc.Types (SscState (..)) @@ -20,13 +21,11 @@ import Pos.Ssc.State.Global import Pos.Ssc.State.Local mkSscState - :: forall ctx m . - ( WithLogger m - , MonadDBRead m - , MonadSlots ctx m - ) - => m SscState -mkSscState = do + :: forall ctx m + . (WithLogger m, MonadDBRead m, MonadSlots ctx m) + => SlotCount + -> m SscState +mkSscState epochSlots = do gState <- sscLoadGlobalState - ld <- sscNewLocalData + ld <- sscNewLocalData epochSlots liftIO $ SscState <$> STM.newTVarIO gState <*> STM.newTVarIO ld diff --git a/ssc/Pos/Ssc/State/Global.hs b/ssc/Pos/Ssc/State/Global.hs index 4dd36b63221..4ed9d5f212f 100644 --- a/ssc/Pos/Ssc/State/Global.hs +++ b/ssc/Pos/Ssc/State/Global.hs @@ -19,9 +19,8 @@ import System.Wlog (WithLogger, logDebug, logInfo) import Universum import Pos.Binary.Ssc () -import Pos.Core (EpochIndex (..), HasGenesisData, - HasProtocolConstants, SlotId (..), - VssCertificatesMap (..)) +import Pos.Core (BlockCount, EpochIndex (..), HasGenesisData, + SlotId (..), VssCertificatesMap (..)) import Pos.DB (MonadDBRead) import qualified Pos.Ssc.DB as DB import Pos.Ssc.Functions (getStableCertsPure) @@ -44,10 +43,12 @@ getGlobalCerts sl = -- | Get stable VSS certificates for given epoch. getStableCerts - :: (MonadSscMem ctx m, MonadIO m, HasGenesisData, HasProtocolConstants) - => EpochIndex -> m VssCertificatesMap -getStableCerts epoch = - getStableCertsPure epoch <$> sscRunGlobalQuery (view sgsVssCertificates) + :: (MonadSscMem ctx m, MonadIO m, HasGenesisData) + => BlockCount + -> EpochIndex + -> m VssCertificatesMap +getStableCerts k epoch = + getStableCertsPure k epoch <$> sscRunGlobalQuery (view sgsVssCertificates) ---------------------------------------------------------------------------- -- Seed diff --git a/ssc/Pos/Ssc/State/Local.hs b/ssc/Pos/Ssc/State/Local.hs index 2e2a1440589..7149b90f4ce 100644 --- a/ssc/Pos/Ssc/State/Local.hs +++ b/ssc/Pos/Ssc/State/Local.hs @@ -10,7 +10,7 @@ module Pos.Ssc.State.Local import Universum -import Pos.Core (HasProtocolConstants, SlotId (..)) +import Pos.Core (SlotCount, SlotId (..), localSlotIndexMinBound) import Pos.DB (MonadDBRead) import Pos.Infra.Slotting (MonadSlots (getCurrentSlot)) import Pos.Ssc.Mem (MonadSscMem, askSscMem) @@ -19,24 +19,25 @@ import Pos.Ssc.Types (SscLocalData (..), sscLocal) -- | Reset local data to empty state. This function can be used when -- we detect that something is really bad. In this case it makes sense -- to remove all local data to be sure it's valid. -sscResetLocal :: - forall ctx m. - ( MonadDBRead m - , MonadSscMem ctx m - , MonadSlots ctx m - ) - => m () -sscResetLocal = do - emptyLD <- sscNewLocalData +sscResetLocal + :: forall ctx m + . (MonadDBRead m, MonadSscMem ctx m, MonadSlots ctx m) + => SlotCount + -> m () +sscResetLocal epochSlots = do + emptyLD <- sscNewLocalData epochSlots localVar <- sscLocal <$> askSscMem atomically $ writeTVar localVar emptyLD -- | Create new (empty) local data. We are using this function instead of -- 'Default' class, because it gives more flexibility. For instance, one -- can read something from DB or get current slot. -sscNewLocalData :: (MonadSlots ctx m, HasProtocolConstants) => m SscLocalData -sscNewLocalData = - SscLocalData mempty . siEpoch . fromMaybe slot0 <$> getCurrentSlot <*> - pure 1 +sscNewLocalData :: MonadSlots ctx m => SlotCount -> m SscLocalData +sscNewLocalData epochSlots = + SscLocalData mempty + . siEpoch + . fromMaybe slot0 + <$> getCurrentSlot epochSlots + <*> pure 1 where - slot0 = SlotId 0 minBound + slot0 = SlotId 0 localSlotIndexMinBound diff --git a/ssc/Pos/Ssc/Toss/Base.hs b/ssc/Pos/Ssc/Toss/Base.hs index 1fcf63f38bf..cdaf4145108 100644 --- a/ssc/Pos/Ssc/Toss/Base.hs +++ b/ssc/Pos/Ssc/Toss/Base.hs @@ -47,7 +47,7 @@ import Formatting (ords, sformat, (%)) import System.Wlog (logWarning) import Pos.Binary.Class (AsBinary, fromBinary) -import Pos.Core (CoinPortion, EpochIndex, StakeholderId, +import Pos.Core (BlockCount, CoinPortion, EpochIndex, StakeholderId, VssCertificatesMap (..), addressHash, bvdMpcThd, coinPortionDenominator, getCoinPortion, lookupVss, memberVss, unsafeGetCoin, vcSigningKey, vcVssKey) @@ -94,11 +94,13 @@ hasCertificateToss id = memberVss id <$> getVssCertificates -- | Get 'VssCertificatesMap' containing 'StakeholderId's and -- 'VssPublicKey's of participating nodes for given epoch. -getParticipants :: (MonadError SscVerifyError m, MonadToss m, MonadTossEnv m) - => EpochIndex - -> m VssCertificatesMap -getParticipants epoch = do - stableCerts <- getStableCertificates epoch +getParticipants + :: (MonadError SscVerifyError m, MonadToss m, MonadTossEnv m) + => BlockCount + -> EpochIndex + -> m VssCertificatesMap +getParticipants k epoch = do + stableCerts <- getStableCertificates k epoch richmen <- note (NoRichmen epoch) =<< getRichmen epoch pure $ computeParticipants (getKeys richmen) stableCerts @@ -115,9 +117,12 @@ matchCommitment op = flip matchCommitmentPure op <$> getCommitments checkShares :: (MonadTossRead m, MonadTossEnv m) - => EpochIndex -> (StakeholderId, InnerSharesMap) -> m Bool -checkShares epoch (id, sh) = do - certs <- getStableCertificates epoch + => BlockCount + -> EpochIndex + -> (StakeholderId, InnerSharesMap) + -> m Bool +checkShares k epoch (id, sh) = do + certs <- getStableCertificates k epoch let warnFmt = ("checkShares: no richmen for "%ords%" epoch") getRichmen epoch >>= \case Nothing -> False <$ logWarning (sformat warnFmt epoch) @@ -396,18 +401,18 @@ computeSharesDistr richmen = -- proportions (according to 'computeSharesDistr') -- * shares in the commitment are valid checkCommitmentsPayload - :: (MonadToss m, MonadTossEnv m, MonadError SscVerifyError m, - MonadRandom m) - => EpochIndex + :: (MonadToss m, MonadTossEnv m, MonadError SscVerifyError m, MonadRandom m) + => BlockCount + -> EpochIndex -> CommitmentsMap -> m () -checkCommitmentsPayload epoch (getCommitmentsMap -> comms) = +checkCommitmentsPayload k epoch (getCommitmentsMap -> comms) = -- We don't verify an empty commitments map, because an empty commitments -- map is always valid. Moreover, the commitments check requires us to -- compute 'SharesDistribution', which might be expensive. unless (null comms) $ do richmen <- note (NoRichmen epoch) =<< getRichmen epoch - participants <- getParticipants epoch + participants <- getParticipants k epoch distr <- computeSharesDistr richmen exceptGuard CommittingNoParticipants (`memberVss` participants) (HM.keys comms) @@ -443,14 +448,15 @@ checkOpeningsPayload opens = do -- decrypted shares checkSharesPayload :: (MonadToss m, MonadTossEnv m, MonadError SscVerifyError m) - => EpochIndex + => BlockCount + -> EpochIndex -> SharesMap -> m () -checkSharesPayload epoch shares = do +checkSharesPayload k epoch shares = do -- We intentionally don't check that nodes which decrypted shares sent -- its commitments. If a node decrypted shares correctly, such node is -- useful for us, despite that it didn't send its commitment. - part <- getParticipants epoch + part <- getParticipants k epoch exceptGuard SharesNotRichmen (`memberVss` part) (HM.keys shares) exceptGuardM InternalShareWithoutCommitment @@ -458,7 +464,7 @@ checkSharesPayload epoch shares = do exceptGuardM SharesAlreadySent (notM hasSharesToss) (HM.keys shares) exceptGuardEntryM DecrSharesNotMatchCommitment - (checkShares epoch) (HM.toList shares) + (checkShares k epoch) (HM.toList shares) -- For certificates we check that -- * certificate hasn't been sent already @@ -487,17 +493,17 @@ checkCertificatesPayload epoch certs = do (HM.toList (getVssCertificatesMap certs)) checkPayload - :: (MonadToss m, MonadTossEnv m, MonadError SscVerifyError m, - MonadRandom m) - => EpochIndex + :: (MonadToss m, MonadTossEnv m, MonadError SscVerifyError m, MonadRandom m) + => BlockCount + -> EpochIndex -> SscPayload -> m () -checkPayload epoch payload = do +checkPayload k epoch payload = do let payloadCerts = spVss payload case payload of - CommitmentsPayload comms _ -> checkCommitmentsPayload epoch comms + CommitmentsPayload comms _ -> checkCommitmentsPayload k epoch comms OpeningsPayload opens _ -> checkOpeningsPayload opens - SharesPayload shares _ -> checkSharesPayload epoch shares + SharesPayload shares _ -> checkSharesPayload k epoch shares CertificatesPayload _ -> pass checkCertificatesPayload epoch payloadCerts diff --git a/ssc/Pos/Ssc/Toss/Class.hs b/ssc/Pos/Ssc/Toss/Class.hs index beb4a6a05b8..6522d0faa46 100644 --- a/ssc/Pos/Ssc/Toss/Class.hs +++ b/ssc/Pos/Ssc/Toss/Class.hs @@ -14,8 +14,9 @@ import Control.Monad.Except (ExceptT) import Control.Monad.Trans (MonadTrans) import System.Wlog (WithLogger) -import Pos.Core (BlockVersionData, EpochIndex, EpochOrSlot, - StakeholderId, VssCertificate, VssCertificatesMap) +import Pos.Core (BlockCount, BlockVersionData, EpochIndex, + EpochOrSlot, StakeholderId, VssCertificate, + VssCertificatesMap) import Pos.Core.Ssc (CommitmentsMap, InnerSharesMap, Opening, OpeningsMap, SharesMap, SignedCommitment) import Pos.Lrc.Types (RichmenStakes) @@ -41,7 +42,7 @@ class (Monad m, WithLogger m) => getVssCertificates :: m VssCertificatesMap -- | Retrieve all stable 'VssCertificate's for given epoch. - getStableCertificates :: EpochIndex -> m VssCertificatesMap + getStableCertificates :: BlockCount -> EpochIndex -> m VssCertificatesMap -- | Default implementations for 'MonadTrans'. default getCommitments :: (MonadTrans t, MonadTossRead m', t m' ~ m) => @@ -61,8 +62,8 @@ class (Monad m, WithLogger m) => getVssCertificates = lift getVssCertificates default getStableCertificates :: (MonadTrans t, MonadTossRead m', t m' ~ m) => - EpochIndex -> m VssCertificatesMap - getStableCertificates = lift . getStableCertificates + BlockCount -> EpochIndex -> m VssCertificatesMap + getStableCertificates k = lift . getStableCertificates k instance MonadTossRead m => MonadTossRead (ReaderT s m) instance MonadTossRead m => MonadTossRead (StateT s m) diff --git a/ssc/Pos/Ssc/Toss/Logic.hs b/ssc/Pos/Ssc/Toss/Logic.hs index ec13d6d7e61..11746c6056e 100644 --- a/ssc/Pos/Ssc/Toss/Logic.hs +++ b/ssc/Pos/Ssc/Toss/Logic.hs @@ -16,11 +16,14 @@ import Crypto.Random (MonadRandom) import qualified Data.HashMap.Strict as HM import System.Wlog (logError) -import Pos.Core (EpochIndex, EpochOrSlot (..), HasProtocolConstants, - IsMainHeader, LocalSlotIndex, SlotCount, SlotId (siSlot), - StakeholderId, VssCertificate, epochIndexL, epochOrSlot, - getEpochOrSlot, getVssCertificatesMap, headerSlotL, - mkCoin, mkVssCertificatesMapSingleton, slotSecurityParam) +import Pos.Core (EpochIndex, EpochOrSlot (..), IsMainHeader, + LocalSlotIndex, ProtocolConstants, SlotCount, + SlotId (siSlot), StakeholderId, VssCertificate, + epochIndexL, epochOrSlot, epochOrSlotPred, + epochOrSlotToEnum, getEpochOrSlot, getSlotIndex, + getVssCertificatesMap, headerSlotL, mkCoin, + mkVssCertificatesMapSingleton, pcBlkSecurityParam, + pcSlotSecurityParam) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Ssc (CommitmentsMap (..), InnerSharesMap, Opening, SignedCommitment, SscPayload (..), checkSscPayload, @@ -39,22 +42,29 @@ import Pos.Util.Util (sortWithMDesc) -- MonadToss. If data is valid it is also applied. Otherwise -- SscVerifyError is thrown using 'MonadError' type class. verifyAndApplySscPayload - :: (MonadToss m, MonadTossEnv m, - MonadError SscVerifyError m, MonadRandom m, HasProtocolConstants) - => ProtocolMagic -> Either EpochIndex (Some IsMainHeader) -> SscPayload -> m () -verifyAndApplySscPayload pm eoh payload = do + :: ( MonadToss m + , MonadTossEnv m + , MonadError SscVerifyError m + , MonadRandom m + ) + => ProtocolMagic + -> ProtocolConstants + -> Either EpochIndex (Some IsMainHeader) + -> SscPayload + -> m () +verifyAndApplySscPayload pm pc eoh payload = do -- Check the payload for internal consistency. either (throwError . SscInvalidPayload) pure (checkSscPayload pm payload) -- We can't trust payload from mempool, so we must call -- @verifySscPayload@. - whenLeft eoh $ const $ verifySscPayload pm eoh payload + whenLeft eoh $ const $ verifySscPayload pm pc eoh payload -- We perform @verifySscPayload@ for block when we construct it -- (in the 'recreateGenericBlock'). So this check is just in case. inAssertMode $ - whenRight eoh $ const $ verifySscPayload pm eoh payload + whenRight eoh $ const $ verifySscPayload pm pc eoh payload let blockCerts = spVss payload let curEpoch = either identity (^. epochIndexL) eoh - checkPayload curEpoch payload + checkPayload (pcBlkSecurityParam pc) curEpoch payload -- Apply case eoh of @@ -66,9 +76,9 @@ verifyAndApplySscPayload pm eoh payload = do -- it's guaranteed that rollback on more than 'slotSecurityParam' -- can't happen let indexToCount :: LocalSlotIndex -> SlotCount - indexToCount = fromIntegral . fromEnum + indexToCount = fromIntegral . getSlotIndex let slot = epochOrSlot (const 0) (indexToCount . siSlot) eos - when (slotSecurityParam <= slot && slot < 2 * slotSecurityParam) $ + when (pcSlotSecurityParam pc <= slot && slot < 2 * pcSlotSecurityParam pc) $ resetShares mapM_ putCertificate blockCerts case payload of @@ -94,18 +104,20 @@ applyGenesisBlock epoch = do -- | Rollback application of 'SscPayload's in 'Toss'. First argument is -- 'EpochOrSlot' of oldest block which is subject to rollback. -rollbackSsc :: (MonadToss m, HasProtocolConstants) => - EpochOrSlot +rollbackSsc + :: MonadToss m + => SlotCount + -> EpochOrSlot -> NewestFirst [] SscPayload -> m () -rollbackSsc oldestEOS (NewestFirst payloads) - | oldestEOS == toEnum 0 = do +rollbackSsc epochSlots oldestEOS (NewestFirst payloads) + | oldestEOS == epochOrSlotToEnum epochSlots 0 = do logError "rollbackSsc: most genesis block is passed to rollback" setEpochOrSlot oldestEOS resetCO resetShares | otherwise = do - setEpochOrSlot (pred oldestEOS) + setEpochOrSlot (epochOrSlotPred epochSlots oldestEOS) mapM_ rollbackSscDo payloads where rollbackSscDo (CommitmentsPayload comms _) = @@ -116,11 +128,16 @@ rollbackSsc oldestEOS (NewestFirst payloads) -- | Apply as much data from given 'TossModifier' as possible. normalizeToss - :: (MonadToss m, MonadTossEnv m, MonadRandom m, HasProtocolConstants) - => ProtocolMagic -> EpochIndex -> TossModifier -> m () -normalizeToss pm epoch TossModifier {..} = + :: (MonadToss m, MonadTossEnv m, MonadRandom m) + => ProtocolMagic + -> ProtocolConstants + -> EpochIndex + -> TossModifier + -> m () +normalizeToss pm pc epoch TossModifier {..} = normalizeTossDo pm + pc epoch ( HM.toList (getCommitmentsMap _tmCommitments) , HM.toList _tmOpenings @@ -130,15 +147,19 @@ normalizeToss pm epoch TossModifier {..} = -- | Apply the most valuable from given 'TossModifier' and drop the -- rest. This function can be used if mempool is exhausted. refreshToss - :: (MonadToss m, MonadTossEnv m, MonadRandom m, HasProtocolConstants) - => ProtocolMagic -> EpochIndex -> TossModifier -> m () -refreshToss pm epoch TossModifier {..} = do + :: (MonadToss m, MonadTossEnv m, MonadRandom m) + => ProtocolMagic + -> ProtocolConstants + -> EpochIndex + -> TossModifier + -> m () +refreshToss pm pc epoch TossModifier {..} = do comms <- takeMostValuable epoch (HM.toList (getCommitmentsMap _tmCommitments)) opens <- takeMostValuable epoch (HM.toList _tmOpenings) shares <- takeMostValuable epoch (HM.toList _tmShares) certs <- takeMostValuable epoch (HM.toList (getVssCertificatesMap _tmCertificates)) - normalizeTossDo pm epoch (comms, opens, shares, certs) + normalizeTossDo pm pc epoch (comms, opens, shares, certs) takeMostValuable :: (MonadToss m, MonadTossEnv m) @@ -159,10 +180,14 @@ type TossModifierLists , [(StakeholderId, VssCertificate)]) normalizeTossDo - :: forall m. - (MonadToss m, MonadTossEnv m, MonadRandom m, HasProtocolConstants) - => ProtocolMagic -> EpochIndex -> TossModifierLists -> m () -normalizeTossDo pm epoch (comms, opens, shares, certs) = do + :: forall m + . (MonadToss m, MonadTossEnv m, MonadRandom m) + => ProtocolMagic + -> ProtocolConstants + -> EpochIndex + -> TossModifierLists + -> m () +normalizeTossDo pm pc epoch (comms, opens, shares, certs) = do putsUseful $ map (flip CommitmentsPayload mempty . mkCommitmentsMapUnsafe . one) $ comms @@ -172,5 +197,5 @@ normalizeTossDo pm epoch (comms, opens, shares, certs) = do where putsUseful :: [SscPayload] -> m () putsUseful entries = do - let verifyAndApply = runExceptT . verifyAndApplySscPayload pm (Left epoch) + let verifyAndApply = runExceptT . verifyAndApplySscPayload pm pc (Left epoch) mapM_ verifyAndApply entries diff --git a/ssc/Pos/Ssc/Toss/Pure.hs b/ssc/Pos/Ssc/Toss/Pure.hs index 41bca30c30b..300fbd190c1 100644 --- a/ssc/Pos/Ssc/Toss/Pure.hs +++ b/ssc/Pos/Ssc/Toss/Pure.hs @@ -21,7 +21,7 @@ import System.Wlog (CanLog, HasLoggerName (..), LogEvent, runNamedPureLog) import Pos.Core (BlockVersionData, EpochIndex, HasGenesisData, - HasProtocolConstants, crucialSlot, genesisVssCerts) + crucialSlot, genesisVssCerts) import Pos.Lrc.Types (RichmenSet, RichmenStakes) import Pos.Ssc.Base (deleteSignedCommitment, insertSignedCommitment) import Pos.Ssc.Toss.Class (MonadToss (..), MonadTossEnv (..), @@ -49,25 +49,25 @@ newtype PureTossWithEnv a = PureTossWithEnv } deriving (Functor, Applicative, Monad, Rand.MonadRandom, CanLog, HasLoggerName) -deriving instance (HasProtocolConstants, HasGenesisData) => MonadTossRead PureTossWithEnv -deriving instance (HasProtocolConstants, HasGenesisData) => MonadToss PureTossWithEnv +deriving instance HasGenesisData => MonadTossRead PureTossWithEnv +deriving instance HasGenesisData => MonadToss PureTossWithEnv -instance (HasGenesisData, HasProtocolConstants) => MonadTossRead PureToss where +instance HasGenesisData => MonadTossRead PureToss where getCommitments = PureToss $ use sgsCommitments getOpenings = PureToss $ use sgsOpenings getShares = PureToss $ use sgsShares getVssCertificates = PureToss $ uses sgsVssCertificates VCD.certs - getStableCertificates epoch + getStableCertificates k epoch | epoch == 0 = pure $ genesisVssCerts | otherwise = PureToss $ uses sgsVssCertificates $ - VCD.certs . VCD.setLastKnownSlot (crucialSlot epoch) + VCD.certs . VCD.setLastKnownSlot (crucialSlot k epoch) instance MonadTossEnv PureTossWithEnv where getRichmen epoch = PureTossWithEnv $ view (_1 . at epoch) getAdoptedBVData = PureTossWithEnv $ view _2 -instance (HasProtocolConstants, HasGenesisData) => MonadToss PureToss where +instance HasGenesisData => MonadToss PureToss where putCommitment signedComm = PureToss $ sgsCommitments %= insertSignedCommitment signedComm putOpening id op = PureToss $ sgsOpenings . at id .= Just op diff --git a/ssc/Pos/Ssc/Toss/Trans.hs b/ssc/Pos/Ssc/Toss/Trans.hs index 7853362ffc1..72e16dde954 100644 --- a/ssc/Pos/Ssc/Toss/Trans.hs +++ b/ssc/Pos/Ssc/Toss/Trans.hs @@ -59,7 +59,7 @@ instance MonadTossRead m => getOpenings = ether $ (<>) <$> use tmOpenings <*> getOpenings getShares = ether $ (<>) <$> use tmShares <*> getShares getVssCertificates = ether $ (<>) <$> use tmCertificates <*> getVssCertificates - getStableCertificates = ether . getStableCertificates + getStableCertificates pc = ether . getStableCertificates pc instance MonadTossEnv m => MonadTossEnv (TossT m) where diff --git a/ssc/Pos/Ssc/Toss/Types.hs b/ssc/Pos/Ssc/Toss/Types.hs index 4ee77f3827c..019d8b5d310 100644 --- a/ssc/Pos/Ssc/Toss/Types.hs +++ b/ssc/Pos/Ssc/Toss/Types.hs @@ -16,7 +16,7 @@ import Control.Lens (makeLenses) import qualified Data.Text.Buildable as Buildable import Universum -import Pos.Core (HasProtocolConstants, LocalSlotIndex, SlotId, +import Pos.Core (BlockCount, LocalSlotIndex, SlotId, VssCertificatesMap) import Pos.Core.Ssc (CommitmentsMap, OpeningsMap, SharesMap) import Pos.Ssc.Base (isCommitmentId, isCommitmentIdx, isOpeningId, @@ -36,17 +36,19 @@ instance Buildable SscTag where build SharesMsg = "shares" build VssCertificateMsg = "VSS certificate" -isGoodSlotForTag :: HasProtocolConstants => SscTag -> LocalSlotIndex -> Bool -isGoodSlotForTag CommitmentMsg = isCommitmentIdx -isGoodSlotForTag OpeningMsg = isOpeningIdx -isGoodSlotForTag SharesMsg = isSharesIdx -isGoodSlotForTag VssCertificateMsg = const True +isGoodSlotForTag :: BlockCount -> SscTag -> LocalSlotIndex -> Bool +isGoodSlotForTag k = \case + CommitmentMsg -> isCommitmentIdx k + OpeningMsg -> isOpeningIdx k + SharesMsg -> isSharesIdx k + VssCertificateMsg -> const True -isGoodSlotIdForTag :: HasProtocolConstants => SscTag -> SlotId -> Bool -isGoodSlotIdForTag CommitmentMsg = isCommitmentId -isGoodSlotIdForTag OpeningMsg = isOpeningId -isGoodSlotIdForTag SharesMsg = isSharesId -isGoodSlotIdForTag VssCertificateMsg = const True +isGoodSlotIdForTag :: BlockCount -> SscTag -> SlotId -> Bool +isGoodSlotIdForTag k = \case + CommitmentMsg -> isCommitmentId k + OpeningMsg -> isOpeningId k + SharesMsg -> isSharesId k + VssCertificateMsg -> const True data TossModifier = TossModifier { _tmCommitments :: !CommitmentsMap diff --git a/ssc/Pos/Ssc/Worker.hs b/ssc/Pos/Ssc/Worker.hs index 7a1cefeaf0f..981446b06f3 100644 --- a/ssc/Pos/Ssc/Worker.hs +++ b/ssc/Pos/Ssc/Worker.hs @@ -22,12 +22,13 @@ import qualified Test.QuickCheck as QC import Pos.Arbitrary.Ssc () import Pos.Binary.Class (AsBinary, asBinary, fromBinary) import Pos.Binary.Ssc () -import Pos.Core (EpochIndex, SlotId (..), StakeholderId, - Timestamp (..), VssCertificate (..), - VssCertificatesMap (..), blkSecurityParam, bvdMpcThd, +import Pos.Core (BlockCount, EpochIndex, ProtocolConstants, + SlotId (..), StakeholderId, Timestamp (..), + VssCertificate (..), VssCertificatesMap (..), bvdMpcThd, getOurSecretKey, getOurStakeholderId, getSlotIndex, - lookupVss, memberVss, mkLocalSlotIndex, mkVssCertificate, - slotSecurityParam, vssMaxTTL) + kEpochSlots, kSlotSecurityParam, lookupVss, memberVss, + mkLocalSlotIndex, mkVssCertificate, pcBlkSecurityParam, + pcEpochSlots, vssMaxTTL) import Pos.Core.Ssc (InnerSharesMap, Opening, SignedCommitment, getCommitmentsMap, randCommitmentAndOpening) import Pos.Crypto (ProtocolMagic, SecretKey, VssKeyPair, VssPublicKey, @@ -68,11 +69,14 @@ import Pos.Util.AssertMode (inAssertMode) import Pos.Util.Util (getKeys, leftToPanic) sscWorkers - :: ( SscMode ctx m - , HasMisbehaviorMetrics ctx - ) - => ProtocolMagic -> [Diffusion m -> m ()] -sscWorkers pm = [onNewSlotSsc pm, checkForIgnoredCommitmentsWorker] + :: (SscMode ctx m, HasMisbehaviorMetrics ctx) + => ProtocolMagic + -> ProtocolConstants + -> [Diffusion m -> m ()] +sscWorkers pm pc = + [ onNewSlotSsc pm pc + , checkForIgnoredCommitmentsWorker (pcBlkSecurityParam pc) + ] shouldParticipate :: SscMode ctx m => EpochIndex -> m Bool shouldParticipate epoch = do @@ -88,32 +92,45 @@ shouldParticipate epoch = do -- CHECK: @onNewSlotSsc -- #checkNSendOurCert onNewSlotSsc - :: ( SscMode ctx m - ) + :: SscMode ctx m => ProtocolMagic + -> ProtocolConstants -> Diffusion m -> m () -onNewSlotSsc pm = \diffusion -> onNewSlot defaultOnNewSlotParams $ \slotId -> - recoveryCommGuard "onNewSlot worker in SSC" $ do - sscGarbageCollectLocalData slotId - whenM (shouldParticipate $ siEpoch slotId) $ do - behavior <- view sscContext >>= - atomically . readTVar . scBehavior - checkNSendOurCert pm (sendSscCert diffusion) - onNewSlotCommitment pm slotId (sendSscCommitment diffusion) - onNewSlotOpening pm (sbSendOpening behavior) slotId (sendSscOpening diffusion) - onNewSlotShares pm (sbSendShares behavior) slotId (sendSscShares diffusion) +onNewSlotSsc pm pc diffusion = + onNewSlot (pcEpochSlots pc) defaultOnNewSlotParams $ \slotId -> + recoveryCommGuard (pcBlkSecurityParam pc) "onNewSlot worker in SSC" + $ do + sscGarbageCollectLocalData slotId + whenM (shouldParticipate $ siEpoch slotId) $ do + behavior <- + view sscContext >>= atomically . readTVar . scBehavior + checkNSendOurCert pm pc (sendSscCert diffusion) + onNewSlotCommitment pm + pc + slotId + (sendSscCommitment diffusion) + onNewSlotOpening pm + pc + (sbSendOpening behavior) + slotId + (sendSscOpening diffusion) + onNewSlotShares pm + pc + (sbSendShares behavior) + slotId + (sendSscShares diffusion) -- CHECK: @checkNSendOurCert -- Checks whether 'our' VSS certificate has been announced checkNSendOurCert - :: forall ctx m. - ( SscMode ctx m - ) + :: forall ctx m + . SscMode ctx m => ProtocolMagic + -> ProtocolConstants -> (VssCertificate -> m ()) -> m () -checkNSendOurCert pm sendCert = do +checkNSendOurCert pm pc sendCert = do ourId <- getOurStakeholderId let sendCertDo resend slot = do if resend then @@ -123,11 +140,11 @@ checkNSendOurCert pm sendCert = do "Our VssCertificate hasn't been announced yet or TTL has expired, \ \we will announce it now." ourVssCertificate <- getOurVssCertificate slot - sscProcessOurMessage (sscProcessCertificate pm ourVssCertificate) + sscProcessOurMessage (sscProcessCertificate pm pc ourVssCertificate) _ <- sendCert ourVssCertificate logDebugS "Announced our VssCertificate." - slMaybe <- getCurrentSlot + slMaybe <- getCurrentSlot $ pcEpochSlots pc case slMaybe of Nothing -> pass Just sl -> do @@ -157,7 +174,7 @@ checkNSendOurCert pm sendCert = do let vssKey = asBinary $ toVssPublicKey ourVssKeyPair createOurCert = mkVssCertificate pm ourSk vssKey . - (+) (vssMaxTTL - 1) . siEpoch + (+) (vssMaxTTL pc - 1) . siEpoch return $ createOurCert slot getOurVssKeyPair :: SscMode ctx m => m VssKeyPair @@ -165,19 +182,19 @@ getOurVssKeyPair = views sscContext scVssKeyPair -- Commitments-related part of new slot processing onNewSlotCommitment - :: ( SscMode ctx m - ) + :: SscMode ctx m => ProtocolMagic + -> ProtocolConstants -> SlotId -> (SignedCommitment -> m ()) -> m () -onNewSlotCommitment pm slotId@SlotId {..} sendCommitment - | not (isCommitmentIdx siSlot) = pass +onNewSlotCommitment pm pc slotId@SlotId {..} sendCommitment + | not (isCommitmentIdx k siSlot) = pass | otherwise = do ourId <- getOurStakeholderId shouldSendCommitment <- andM [ not . hasCommitment ourId <$> sscGetGlobalState - , memberVss ourId <$> getStableCerts siEpoch] + , memberVss ourId <$> getStableCerts k siEpoch] if shouldSendCommitment then logDebugS "We should send commitment" else @@ -189,10 +206,12 @@ onNewSlotCommitment pm slotId@SlotId {..} sendCommitment Just comm -> logDebugS stillValidMsg >> sendOurCommitment comm Nothing -> onNewSlotCommDo where + k = pcBlkSecurityParam pc + onNewSlotCommDo = do ourSk <- getOurSecretKey logDebugS $ sformat ("Generating secret for "%ords%" epoch") siEpoch - generated <- generateAndSetNewSecret pm ourSk slotId + generated <- generateAndSetNewSecret pm k ourSk slotId case generated of Nothing -> logWarningS "I failed to generate secret for SSC" Just comm -> do @@ -200,20 +219,20 @@ onNewSlotCommitment pm slotId@SlotId {..} sendCommitment sendOurCommitment comm sendOurCommitment comm = do - sscProcessOurMessage (sscProcessCommitment pm comm) - sendOurData sendCommitment CommitmentMsg comm siEpoch 0 + sscProcessOurMessage (sscProcessCommitment pm pc comm) + sendOurData k sendCommitment CommitmentMsg comm siEpoch 0 -- Openings-related part of new slot processing onNewSlotOpening - :: ( SscMode ctx m - ) + :: SscMode ctx m => ProtocolMagic + -> ProtocolConstants -> SscOpeningParams -> SlotId -> (Opening -> m ()) -> m () -onNewSlotOpening pm params SlotId {..} sendOpening - | not $ isOpeningIdx siSlot = pass +onNewSlotOpening pm pc params SlotId {..} sendOpening + | not $ isOpeningIdx k siSlot = pass | otherwise = do ourId <- getOurStakeholderId globalData <- sscGetGlobalState @@ -224,6 +243,8 @@ onNewSlotOpening pm params SlotId {..} sendOpening Nothing -> logWarningS noOpenMsg Just open -> sendOpeningDo ourId open where + k = pcBlkSecurityParam pc + noCommMsg = "We're not sending opening, because there is no commitment \ \from us in global state" @@ -235,28 +256,29 @@ onNewSlotOpening pm params SlotId {..} sendOpening SscOpeningNormal -> pure (Just open) SscOpeningWrong -> Just <$> liftIO (QC.generate QC.arbitrary) whenJust mbOpen' $ \open' -> do - sscProcessOurMessage (sscProcessOpening pm ourId open') - sendOurData sendOpening OpeningMsg open' siEpoch 2 + sscProcessOurMessage (sscProcessOpening pm pc ourId open') + sendOurData k sendOpening OpeningMsg open' siEpoch 2 -- Shares-related part of new slot processing onNewSlotShares - :: ( SscMode ctx m - ) + :: SscMode ctx m => ProtocolMagic + -> ProtocolConstants -> SscSharesParams -> SlotId -> (InnerSharesMap -> m ()) -> m () -onNewSlotShares pm params SlotId {..} sendShares = do +onNewSlotShares pm pc params SlotId {..} sendShares = do ourId <- getOurStakeholderId -- Send decrypted shares that others have sent us shouldSendShares <- do sharesInBlockchain <- hasShares ourId <$> sscGetGlobalState - return $ isSharesIdx siSlot && not sharesInBlockchain + return $ isSharesIdx k siSlot && not sharesInBlockchain when shouldSendShares $ do ourVss <- views sscContext scVssKeyPair sendSharesDo ourId =<< getOurShares ourVss where + k = pcBlkSecurityParam pc sendSharesDo ourId shares = do let shares' = case params of SscSharesNone -> mempty @@ -269,8 +291,8 @@ onNewSlotShares pm params SlotId {..} sendShares = do shares & partsOf each %~ reverse unless (HM.null shares') $ do let lShares = fmap (map asBinary) shares' - sscProcessOurMessage (sscProcessShares pm ourId lShares) - sendOurData sendShares SharesMsg lShares siEpoch 4 + sscProcessOurMessage (sscProcessShares pm pc ourId lShares) + sendOurData k sendShares SharesMsg lShares siEpoch 4 sscProcessOurMessage :: (Buildable err, SscMode ctx m) @@ -285,17 +307,18 @@ sscProcessOurMessage action = sendOurData :: SscMode ctx m - => (contents -> m ()) + => BlockCount + -> (contents -> m ()) -> SscTag -> contents -> EpochIndex -> Word16 -> m () -sendOurData sendIt msgTag dt epoch slMultiplier = do +sendOurData k sendIt msgTag dt epoch slMultiplier = do -- Note: it's not necessary to create a new thread here, because -- in one invocation of onNewSlot we can't process more than one -- type of message. - waitUntilSend msgTag epoch slMultiplier + waitUntilSend k msgTag epoch slMultiplier logInfoS $ sformat ("Announcing our "%build) msgTag _ <- sendIt dt logDebugS $ sformat ("Sent our " %build%" to neighbors") msgTag @@ -307,16 +330,16 @@ sendOurData sendIt msgTag dt epoch slMultiplier = do -- node doesn't have recent enough blocks and needs to be -- synchronized). generateAndSetNewSecret - :: forall ctx m. - ( SscMode ctx m - ) + :: forall ctx m + . SscMode ctx m => ProtocolMagic + -> BlockCount -> SecretKey -> SlotId -- ^ Current slot -> m (Maybe SignedCommitment) -generateAndSetNewSecret pm sk SlotId {..} = do +generateAndSetNewSecret pm k sk SlotId {..} = do richmen <- getSscRichmen "generateAndSetNewSecret" siEpoch - certs <- getStableCerts siEpoch + certs <- getStableCerts k siEpoch inAssertMode $ do let participantIds = HM.keys . getVssCertificatesMap $ @@ -372,11 +395,14 @@ randomTimeInInterval interval = waitUntilSend :: SscMode ctx m - => SscTag -> EpochIndex -> Word16 -> m () -waitUntilSend msgTag epoch slMultiplier = do - let slot = - leftToPanic "waitUntilSend: " $ - mkLocalSlotIndex $ slMultiplier * fromIntegral slotSecurityParam + => BlockCount + -> SscTag + -> EpochIndex + -> Word16 + -> m () +waitUntilSend k msgTag epoch slMultiplier = do + let slot = leftToPanic "waitUntilSend: " . mkLocalSlotIndex (kEpochSlots k) $ + slMultiplier * fromIntegral (kSlotSecurityParam k) Timestamp beginning <- getSlotStartEmpatically $ SlotId {siEpoch = epoch, siSlot = slot} @@ -400,15 +426,16 @@ waitUntilSend msgTag epoch slMultiplier = do ---------------------------------------------------------------------------- checkForIgnoredCommitmentsWorker - :: forall ctx m. - ( SscMode ctx m - , HasMisbehaviorMetrics ctx - ) - => Diffusion m + :: forall ctx m + . (SscMode ctx m, HasMisbehaviorMetrics ctx) + => BlockCount + -> Diffusion m -> m () -checkForIgnoredCommitmentsWorker = \_ -> do +checkForIgnoredCommitmentsWorker k _ = do counter <- newTVarIO 0 - onNewSlot defaultOnNewSlotParams (checkForIgnoredCommitmentsWorkerImpl counter) + onNewSlot (kEpochSlots k) + defaultOnNewSlotParams + (checkForIgnoredCommitmentsWorkerImpl k 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 @@ -420,16 +447,17 @@ checkForIgnoredCommitmentsWorker = \_ -> do -- detect unexpected absence of our commitment and is reset to 0 when -- our commitment appears in blocks. checkForIgnoredCommitmentsWorkerImpl - :: forall ctx m. - ( SscMode ctx m - , HasMisbehaviorMetrics ctx - ) - => TVar Word -> SlotId -> m () -checkForIgnoredCommitmentsWorkerImpl counter SlotId {..} + :: forall ctx m + . (SscMode ctx m, HasMisbehaviorMetrics ctx) + => BlockCount + -> TVar Word + -> SlotId + -> m () +checkForIgnoredCommitmentsWorkerImpl k counter SlotId {..} -- It's enough to do this check once per epoch near the end of the epoch. - | getSlotIndex siSlot /= 9 * fromIntegral blkSecurityParam = pass + | getSlotIndex siSlot /= 9 * fromIntegral k = pass | otherwise = - recoveryCommGuard "checkForIgnoredCommitmentsWorker" $ + recoveryCommGuard k "checkForIgnoredCommitmentsWorker" $ whenM (shouldParticipate siEpoch) $ do ourId <- getOurStakeholderId globalCommitments <- diff --git a/tools/src/blockchain-analyser/Main.hs b/tools/src/blockchain-analyser/Main.hs index 6952e3ff0cd..9ed100ae25d 100644 --- a/tools/src/blockchain-analyser/Main.hs +++ b/tools/src/blockchain-analyser/Main.hs @@ -90,7 +90,7 @@ main = do action args action :: CLIOptions -> Production () -action cli@CLIOptions{..} = withConfigurations Nothing conf $ \_ _ -> do +action cli@CLIOptions{..} = withConfigurations Nothing conf $ \_ _ _ -> do -- Render the first report sizes <- liftIO (canonicalizePath dbPath >>= dbSizes) liftIO $ putText $ render uom printMode sizes diff --git a/tools/src/dbgen/Main.hs b/tools/src/dbgen/Main.hs index 46b158b2add..59ea697812a 100644 --- a/tools/src/dbgen/Main.hs +++ b/tools/src/dbgen/Main.hs @@ -20,7 +20,8 @@ import qualified Network.Transport.TCP as TCP import Options.Generic (getRecord) import Pos.Client.CLI (CommonArgs (..), CommonNodeArgs (..), NodeArgs (..), getNodeParams, gtSscParams) -import Pos.Core (ProtocolMagic, Timestamp (..), epochSlots) +import Pos.Core (ProtocolConstants, ProtocolMagic, Timestamp (..), + pcBlkSecurityParam) import Pos.DB.DB (initNodeDBs) import Pos.DB.Rocks.Functions (openNodeDBs) import Pos.DB.Rocks.Types (NodeDBs) @@ -62,11 +63,12 @@ defaultNetworkConfig ncTopology = NetworkConfig { newRealModeContext :: HasConfigurations => ProtocolMagic + -> ProtocolConstants -> NodeDBs -> ConfigurationOptions -> FilePath -> Production (RealModeContext ()) -newRealModeContext pm dbs confOpts secretKeyPath = do +newRealModeContext pm pc dbs confOpts secretKeyPath = do let nodeArgs = NodeArgs { behaviorConfigPath = Nothing } @@ -107,7 +109,7 @@ newRealModeContext pm dbs confOpts secretKeyPath = do nodeParams <- getNodeParams loggerName cArgs nodeArgs let vssSK = fromJust $ npUserSecret nodeParams ^. usVss let gtParams = gtSscParams cArgs vssSK (npBehaviorConfig nodeParams) - bracketNodeResources @() nodeParams gtParams (txpGlobalSettings pm) (initNodeDBs pm epochSlots) $ \NodeResources{..} -> + bracketNodeResources @() (pcBlkSecurityParam pc) nodeParams gtParams (txpGlobalSettings pm) (initNodeDBs pm pc) $ \NodeResources{..} -> RealModeContext <$> pure dbs <*> pure nrSscState <*> pure nrTxpState @@ -122,17 +124,18 @@ newRealModeContext pm dbs confOpts secretKeyPath = do walletRunner :: HasConfigurations => ProtocolMagic + -> ProtocolConstants -> ConfigurationOptions -> NodeDBs -> FilePath -> WalletDB -> UberMonad a -> IO a -walletRunner pm confOpts dbs secretKeyPath ws act = runProduction $ do +walletRunner pm pc confOpts dbs secretKeyPath ws act = runProduction $ do wwmc <- WalletWebModeContext <$> pure ws <*> newTVarIO def <*> liftIO newTQueueIO - <*> newRealModeContext pm dbs confOpts secretKeyPath + <*> newRealModeContext pm pc dbs confOpts secretKeyPath runReaderT act wwmc newWalletState :: MonadIO m => Bool -> FilePath -> m WalletDB @@ -160,7 +163,7 @@ main = do cli@CLI{..} <- getRecord "DBGen" let cfg = newConfig cli - withConfigurations Nothing cfg $ \_ pm -> do + withConfigurations Nothing cfg $ \_ pm pc -> do when showStats (showStatsAndExit walletPath) say $ bold "Starting the modification of the wallet..." @@ -172,7 +175,7 @@ main = do ws <- newWalletState (isJust addTo) walletPath -- Recreate or not let generatedWallet = generateWalletDB cli spec - walletRunner pm cfg dbs secretKeyPath ws generatedWallet + walletRunner pm pc cfg dbs secretKeyPath ws generatedWallet closeState ws showStatsData "after" walletPath diff --git a/tools/src/keygen/Main.hs b/tools/src/keygen/Main.hs index 71f9dd3af9e..8a3231e725c 100644 --- a/tools/src/keygen/Main.hs +++ b/tools/src/keygen/Main.hs @@ -18,9 +18,10 @@ import qualified Text.JSON.Canonical as CanonicalJSON import Pos.Binary (asBinary, serialize') import qualified Pos.Client.CLI as CLI import Pos.Core (CoreConfiguration (..), GenesisConfiguration (..), - ProtocolMagic, RichSecrets (..), addressHash, ccGenesis, - coreConfiguration, generateFakeAvvm, generateRichSecrets, - mkVssCertificate, vcSigningKey, vssMaxTTL) + ProtocolConstants, ProtocolMagic, RichSecrets (..), + addressHash, ccGenesis, coreConfiguration, + generateFakeAvvm, generateRichSecrets, mkVssCertificate, + vcSigningKey, vssMaxTTL) import Pos.Crypto (EncryptedSecretKey (..), SecretKey (..), VssKeyPair, fullPublicKeyF, hashHexF, noPassEncrypt, redeemPkB64F, toPublic, toVssPublicKey) @@ -129,9 +130,12 @@ generateKeysByGenesis GenKeysOptions{..} = do logInfo (toText gkoOutDir <> " generated successfully") genVssCert - :: (HasConfigurations, WithLogger m, MonadIO m) - => ProtocolMagic -> FilePath -> m () -genVssCert pm path = do + :: (WithLogger m, MonadIO m) + => ProtocolMagic + -> ProtocolConstants + -> FilePath + -> m () +genVssCert pm pc path = do us <- readUserSecret path let primKey = fromMaybe (error "No primary key") (us ^. usPrimKey) vssKey = fromMaybe (error "No VSS key") (us ^. usVss) @@ -139,7 +143,7 @@ genVssCert pm path = do pm primKey (asBinary (toVssPublicKey vssKey)) - (vssMaxTTL - 1) + (vssMaxTTL pc - 1) putText $ sformat ("JSON: key "%hashHexF%", value "%stext) (addressHash $ vcSigningKey cert) (decodeUtf8 $ @@ -155,12 +159,12 @@ main :: IO () main = do KeygenOptions{..} <- getKeygenOptions setupLogging Nothing $ productionB <> termSeveritiesOutB debugPlus - usingLoggerName "keygen" $ withConfigurations Nothing koConfigurationOptions $ \_ pm -> do + usingLoggerName "keygen" $ withConfigurations Nothing koConfigurationOptions $ \_ pm pc -> do logInfo "Processing command" case koCommand of RearrangeMask msk -> rearrange msk GenerateKey path -> genPrimaryKey path - GenerateVss path -> genVssCert pm path + GenerateVss path -> genVssCert pm pc path ReadKey path -> readKey path DumpAvvmSeeds opts -> dumpAvvmSeeds opts GenerateKeysBySpec gkbg -> generateKeysByGenesis gkbg diff --git a/tools/src/launcher/Main.hs b/tools/src/launcher/Main.hs index 754ccecb3ca..2494a557cd0 100644 --- a/tools/src/launcher/Main.hs +++ b/tools/src/launcher/Main.hs @@ -303,7 +303,7 @@ main = set Log.ltFiles [Log.HandlerWrap "launcher" Nothing] . set Log.ltSeverity (Just Log.debugPlus) logException loggerName . Log.usingLoggerName loggerName $ - withConfigurations Nothing loConfiguration $ \_ pm -> do + withConfigurations Nothing loConfiguration $ \_ pm _ -> do -- Generate TLS certificates as needed generateTlsCertificates loConfiguration loX509ToolPath loTlsPath diff --git a/txp/src/Pos/Txp/Logic/Local.hs b/txp/src/Pos/Txp/Logic/Local.hs index 7f051c979bb..397b2e22b68 100644 --- a/txp/src/Pos/Txp/Logic/Local.hs +++ b/txp/src/Pos/Txp/Logic/Local.hs @@ -30,7 +30,7 @@ import System.Wlog (NamedPureLogger, WithLogger, launchNamedPureLog, logDebug, logError, logWarning) import Pos.Core (BlockVersionData, EpochIndex, HeaderHash, - ProtocolMagic, siEpoch) + ProtocolMagic, SlotCount, siEpoch) import Pos.Core.Txp (TxAux (..), TxId, TxUndo) import Pos.Crypto (WithHash (..)) import Pos.DB.Class (MonadGState (..)) @@ -65,23 +65,26 @@ type TxpProcessTransactionMode ctx m = -- transaction in 'TxAux'. Separation is supported for optimization -- only. txProcessTransaction - :: ( TxpProcessTransactionMode ctx m) - => ProtocolMagic -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -txProcessTransaction pm itw = - withStateLock LowPriority ProcessTransaction $ \__tip -> txProcessTransactionNoLock pm itw + :: TxpProcessTransactionMode ctx m + => ProtocolMagic + -> SlotCount + -> (TxId, TxAux) + -> m (Either ToilVerFailure ()) +txProcessTransaction pm epochSlots itw = + withStateLock LowPriority ProcessTransaction + $ \__tip -> txProcessTransactionNoLock pm epochSlots itw -- | Unsafe version of 'txProcessTransaction' which doesn't take a -- lock. Can be used in tests. txProcessTransactionNoLock - :: forall ctx m. - ( TxpLocalWorkMode ctx m - , MempoolExt m ~ () - ) + :: forall ctx m + . (TxpLocalWorkMode ctx m, MempoolExt m ~ ()) => ProtocolMagic + -> SlotCount -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -txProcessTransactionNoLock pm = - txProcessTransactionAbstract buildContext processTxHoisted +txProcessTransactionNoLock pm epochSlots = + txProcessTransactionAbstract epochSlots buildContext processTxHoisted where buildContext :: Utxo -> TxAux -> m () buildContext _ _ = pure () @@ -97,11 +100,12 @@ txProcessTransactionNoLock pm = txProcessTransactionAbstract :: forall extraEnv extraState ctx m a. (TxpLocalWorkMode ctx m, MempoolExt m ~ extraState) - => (Utxo -> TxAux -> m extraEnv) + => SlotCount + -> (Utxo -> TxAux -> m extraEnv) -> (BlockVersionData -> EpochIndex -> (TxId, TxAux) -> ExceptT ToilVerFailure (ExtendedLocalToilM extraEnv extraState) a) -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -txProcessTransactionAbstract buildEnv txAction itw@(txId, txAux) = reportTipMismatch $ runExceptT $ do +txProcessTransactionAbstract epochSlots buildEnv txAction itw@(txId, txAux) = reportTipMismatch $ runExceptT $ do -- Note: we need to read tip from the DB and check that it's the -- same as the one in mempool. That's because mempool state is -- valid only with respect to the tip stored there. Normally tips @@ -117,7 +121,7 @@ txProcessTransactionAbstract buildEnv txAction itw@(txId, txAux) = reportTipMism -- sure that GState won't change, because changing it requires -- 'StateLock' which we own inside this function. tipDB <- lift GS.getTip - epoch <- siEpoch <$> (note ToilSlotUnknown =<< getCurrentSlot) + epoch <- siEpoch <$> (note ToilSlotUnknown =<< getCurrentSlot epochSlots) utxoModifier <- withTxpLocalData getUtxoModifier utxo <- buildUtxo utxoModifier [txAux] extraEnv <- lift $ buildEnv utxo txAux @@ -176,34 +180,39 @@ txProcessTransactionAbstract buildEnv txAction itw@(txId, txAux) = reportTipMism -- | 2. Remove invalid transactions from MemPool -- | 3. Set new tip to txp local data txNormalize - :: forall ctx m. - ( TxpLocalWorkMode ctx m - , MempoolExt m ~ () - ) - => ProtocolMagic -> m () -txNormalize = - txNormalizeAbstract buildContext . normalizeToilHoisted + :: forall ctx m + . (TxpLocalWorkMode ctx m, MempoolExt m ~ ()) + => ProtocolMagic + -> SlotCount + -> m () +txNormalize pm epochSlots = txNormalizeAbstract epochSlots + buildContext + normalizeToilHoisted where buildContext :: Utxo -> [TxAux] -> m () buildContext _ _ = pure () - normalizeToilHoisted :: - ProtocolMagic - -> BlockVersionData + normalizeToilHoisted + :: BlockVersionData -> EpochIndex -> HashMap TxId TxAux -> ExtendedLocalToilM () () () - normalizeToilHoisted pm bvd epoch txs = + normalizeToilHoisted bvd epoch txs = extendLocalToilM $ normalizeToil pm bvd (tcAssetLockedSrcAddrs txpConfiguration) epoch $ HM.toList txs -txNormalizeAbstract :: - (TxpLocalWorkMode ctx m, MempoolExt m ~ extraState) - => (Utxo -> [TxAux] -> m extraEnv) - -> (BlockVersionData -> EpochIndex -> HashMap TxId TxAux -> ExtendedLocalToilM extraEnv extraState ()) +txNormalizeAbstract + :: (TxpLocalWorkMode ctx m, MempoolExt m ~ extraState) + => SlotCount + -> (Utxo -> [TxAux] -> m extraEnv) + -> ( BlockVersionData + -> EpochIndex + -> HashMap TxId TxAux + -> ExtendedLocalToilM extraEnv extraState () + ) -> m () -txNormalizeAbstract buildEnv normalizeAction = - getCurrentSlot >>= \case +txNormalizeAbstract epochSlots buildEnv normalizeAction = + getCurrentSlot epochSlots >>= \case Nothing -> do tip <- GS.getTip -- Clear and update tip diff --git a/txp/src/Pos/Txp/MemState/Class.hs b/txp/src/Pos/Txp/MemState/Class.hs index 6d55b2c9a07..88aded19d6c 100644 --- a/txp/src/Pos/Txp/MemState/Class.hs +++ b/txp/src/Pos/Txp/MemState/Class.hs @@ -29,7 +29,7 @@ import qualified Control.Concurrent.STM as STM import Data.Default (Default (..)) import qualified Data.HashMap.Strict as HM import Mockable (CurrentTime, Mockable) -import Pos.Core (HeaderHash) +import Pos.Core (HeaderHash, SlotCount) import Pos.Core.Txp (TxAux, TxId) import Pos.Crypto (ProtocolMagic) import Pos.DB.Class (MonadDBRead, MonadGState (..)) @@ -130,8 +130,8 @@ clearTxpMemPool txpData = do type family MempoolExt (m :: * -> *) :: * class Monad m => MonadTxpLocal m where - txpNormalize :: ProtocolMagic -> m () - txpProcessTx :: ProtocolMagic -> (TxId, TxAux) -> m (Either ToilVerFailure ()) + txpNormalize :: ProtocolMagic -> SlotCount -> m () + txpProcessTx :: ProtocolMagic -> SlotCount -> (TxId, TxAux) -> m (Either ToilVerFailure ()) type TxpLocalWorkMode ctx m = ( MonadIO m diff --git a/txp/src/Pos/Txp/Network/Listeners.hs b/txp/src/Pos/Txp/Network/Listeners.hs index 0ce3f6dc39c..8f96977d5c8 100644 --- a/txp/src/Pos/Txp/Network/Listeners.hs +++ b/txp/src/Pos/Txp/Network/Listeners.hs @@ -19,6 +19,7 @@ import System.Wlog (WithLogger, logInfo) import Universum import Pos.Binary.Txp () +import Pos.Core (SlotCount) import Pos.Core.Txp (TxAux (..), TxId) import Pos.Crypto (ProtocolMagic, hash) import qualified Pos.Infra.Communication.Relay as Relay @@ -33,25 +34,33 @@ import Pos.Txp.Network.Types (TxMsgContents (..)) handleTxDo :: TxpMode ctx m => ProtocolMagic + -> SlotCount -> (JLEvent -> m ()) -- ^ How to log transactions -> TxAux -- ^ Incoming transaction to be processed -> m Bool -handleTxDo pm logTx txAux = do +handleTxDo pm epochSlots logTx txAux = do let txId = hash (taTx txAux) - res <- txpProcessTx pm (txId, txAux) + res <- txpProcessTx pm epochSlots (txId, txAux) let json me = logTx $ JLTxReceived $ JLTxR - { jlrTxId = sformat build txId - , jlrError = me + { jlrTxId = sformat build txId + , jlrError = me } case res of Right _ -> do - logInfo $ - sformat ("Transaction has been added to storage: "%build) txId + logInfo $ sformat + ("Transaction has been added to storage: " % build) + txId json Nothing pure True Left er -> do - logInfo $ - sformat ("Transaction hasn't been added to storage: "%build%" , reason: "%build) txId er + logInfo $ sformat + ( "Transaction hasn't been added to storage: " + % build + % " , reason: " + % build + ) + txId + er json $ Just $ sformat build er pure False diff --git a/txp/test/Test/Pos/Txp/Toil/UtxoSpec.hs b/txp/test/Test/Pos/Txp/Toil/UtxoSpec.hs index c4451ee2f2a..ad0be3b7fa0 100644 --- a/txp/test/Test/Pos/Txp/Toil/UtxoSpec.hs +++ b/txp/test/Test/Pos/Txp/Toil/UtxoSpec.hs @@ -19,7 +19,7 @@ import Test.Hspec (Expectation, Spec, describe, expectationFailure, import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Property, arbitrary, counterexample, (==>)) -import Pos.Core (HasConfiguration, addressHash, checkPubKeyAddress, +import Pos.Core (addressHash, checkPubKeyAddress, defaultCoreConfiguration, makePubKeyAddressBoot, makeScriptAddress, mkCoin, sumCoins, withGenesisSpec) import Pos.Core.Txp (Tx (..), TxAux (..), TxIn (..), TxInWitness (..), @@ -52,7 +52,7 @@ import Test.Pos.Util.QuickCheck.Property (qcIsLeft, qcIsRight) spec :: Spec spec = withGenesisSpec 0 defaultCoreConfiguration - $ \pm -> describe "Txp.Toil.Utxo" $ do + $ \pm _ -> describe "Txp.Toil.Utxo" $ do describe "utxoGet (no modifier)" $ do it "returns Nothing when given empty Utxo" $ isNothing (utxoGetSimple mempty myTxIn) diff --git a/update/src/Pos/Update/Context.hs b/update/src/Pos/Update/Context.hs index cc791844078..b939c0a47d5 100644 --- a/update/src/Pos/Update/Context.hs +++ b/update/src/Pos/Update/Context.hs @@ -7,6 +7,7 @@ module Pos.Update.Context import Universum +import Pos.Core (SlotCount) import Pos.DB.Class (MonadDBRead) import Pos.Infra.Slotting (MonadSlots) import Pos.Update.MemState.Types (MemVar, newMemVar) @@ -27,10 +28,9 @@ data UpdateContext = UpdateContext -- | Create initial 'UpdateContext'. mkUpdateContext - :: forall ctx m. - ( MonadIO m - , MonadDBRead m - , MonadSlots ctx m - ) - => m UpdateContext -mkUpdateContext = UpdateContext <$> newEmptyMVar <*> newMVar () <*> newMemVar + :: forall ctx m + . (MonadIO m, MonadDBRead m, MonadSlots ctx m) + => SlotCount + -> m UpdateContext +mkUpdateContext epochSlots = + UpdateContext <$> newEmptyMVar <*> newMVar () <*> newMemVar epochSlots diff --git a/update/src/Pos/Update/DB.hs b/update/src/Pos/Update/DB.hs index 76f72409cac..af79de6da98 100644 --- a/update/src/Pos/Update/DB.hs +++ b/update/src/Pos/Update/DB.hs @@ -51,9 +51,9 @@ import UnliftIO (MonadUnliftIO) import Pos.Binary.Class (serialize') import Pos.Binary.Update () import Pos.Core (ApplicationName, BlockVersion, ChainDifficulty, - HasCoreConfiguration, NumSoftwareVersion, SlotId, - SoftwareVersion (..), StakeholderId, TimeDiff (..), - epochSlots) + HasCoreConfiguration, NumSoftwareVersion, + ProtocolConstants, SlotId, SoftwareVersion (..), + StakeholderId, TimeDiff (..), pcEpochSlots) import Pos.Core.Configuration (genesisBlockVersionData) import Pos.Core.Update (BlockVersionData (..), UpId, UpdateProposal (..)) @@ -173,8 +173,8 @@ instance HasCoreConfiguration => RocksBatchOp UpdateOp where -- Initialization ---------------------------------------------------------------------------- -initGStateUS :: MonadDB m => m () -initGStateUS = do +initGStateUS :: MonadDB m => ProtocolConstants -> m () +initGStateUS pc = do writeBatchGState $ PutSlottingData genesisSlottingData : PutEpochProposers mempty : @@ -184,7 +184,7 @@ initGStateUS = do genesisSlotDuration = bvdSlotDuration genesisBlockVersionData genesisEpochDuration :: Microsecond - genesisEpochDuration = fromIntegral epochSlots * convertUnit genesisSlotDuration + genesisEpochDuration = fromIntegral (pcEpochSlots pc) * convertUnit genesisSlotDuration esdCurrent :: EpochSlottingData esdCurrent = EpochSlottingData diff --git a/update/src/Pos/Update/Logic/Global.hs b/update/src/Pos/Update/Logic/Global.hs index b6ffe311c09..28f3d0853e4 100644 --- a/update/src/Pos/Update/Logic/Global.hs +++ b/update/src/Pos/Update/Logic/Global.hs @@ -16,11 +16,11 @@ import Data.Default (Default (def)) import System.Wlog (WithLogger, modifyLoggerName) import UnliftIO (MonadUnliftIO) -import Pos.Core (ApplicationName, BlockVersion, ComponentBlock (..), - HasCoreConfiguration, HasProtocolConstants, +import Pos.Core (ApplicationName, BlockCount, BlockVersion, + ComponentBlock (..), HasCoreConfiguration, NumSoftwareVersion, ProtocolMagic, SoftwareVersion (..), StakeholderId, addressHash, blockVersionL, epochIndexL, - headerHashG, headerLeaderKeyL, headerSlotL) + headerHashG, headerLeaderKeyL, headerSlotL, kEpochSlots) import Pos.Core.Chrono (NE, NewestFirst, OldestFirst) import Pos.Core.Update (BlockVersionData, UpId, UpdatePayload) import qualified Pos.DB.BatchOp as DB @@ -95,21 +95,22 @@ usApplyBlocks , USGlobalApplyMode ctx m ) => ProtocolMagic + -> BlockCount -> OldestFirst NE UpdateBlock -> Maybe PollModifier -> m [DB.SomeBatchOp] -usApplyBlocks pm blocks modifierMaybe = +usApplyBlocks pm k blocks modifierMaybe = withUSLogger $ processModifier =<< case modifierMaybe of Nothing -> do - verdict <- usVerifyBlocks pm False blocks + verdict <- usVerifyBlocks pm k False blocks either onFailure (return . fst) verdict Just modifier -> do -- TODO: I suppose such sanity checks should be done at higher -- level. inAssertMode $ do - verdict <- usVerifyBlocks pm False blocks + verdict <- usVerifyBlocks pm k False blocks whenLeft verdict $ \v -> onFailure v return modifier where @@ -160,17 +161,18 @@ usVerifyBlocks :: , MonadReporting m ) => ProtocolMagic + -> BlockCount -> Bool -> OldestFirst NE UpdateBlock -> m (Either PollVerFailure (PollModifier, OldestFirst NE USUndo)) -usVerifyBlocks pm verifyAllIsKnown blocks = +usVerifyBlocks pm k verifyAllIsKnown blocks = withUSLogger $ reportUnexpectedError $ processRes <$> run (runExceptT action) where action = do lastAdopted <- getAdoptedBV - mapM (verifyBlock pm lastAdopted verifyAllIsKnown) blocks + mapM (verifyBlock pm k lastAdopted verifyAllIsKnown) blocks run :: PollT (DBPoll n) a -> n (a, PollModifier) run = runDBPoll . runPollT def processRes :: @@ -180,14 +182,23 @@ usVerifyBlocks pm verifyAllIsKnown blocks = processRes (Right undos, modifier) = Right (modifier, undos) verifyBlock - :: (USGlobalVerifyMode ctx m, MonadPoll m, MonadError PollVerFailure m, HasProtocolConstants) - => ProtocolMagic -> BlockVersion -> Bool -> UpdateBlock -> m USUndo -verifyBlock _ _ _ (ComponentBlockGenesis genBlk) = - execRollT $ processGenesisBlock (genBlk ^. epochIndexL) -verifyBlock pm lastAdopted verifyAllIsKnown (ComponentBlockMain header payload) = + :: ( USGlobalVerifyMode ctx m + , MonadPoll m + , MonadError PollVerFailure m + ) + => ProtocolMagic + -> BlockCount + -> BlockVersion + -> Bool + -> UpdateBlock + -> m USUndo +verifyBlock _ k _ _ (ComponentBlockGenesis genBlk) = + execRollT $ processGenesisBlock (kEpochSlots k) (genBlk ^. epochIndexL) +verifyBlock pm k lastAdopted verifyAllIsKnown (ComponentBlockMain header payload) = execRollT $ do verifyAndApplyUSPayload pm + k lastAdopted verifyAllIsKnown (Right header) @@ -198,6 +209,7 @@ verifyBlock pm lastAdopted verifyAllIsKnown (ComponentBlockMain header payload) -- we assume that block version is confirmed. let leaderPk = header ^. headerLeaderKeyL recordBlockIssuance + k (addressHash leaderPk) (header ^. blockVersionL) (header ^. headerSlotL) diff --git a/update/src/Pos/Update/Logic/Local.hs b/update/src/Pos/Update/Logic/Local.hs index 87efc4ef625..a060a8c7955 100644 --- a/update/src/Pos/Update/Logic/Local.hs +++ b/update/src/Pos/Update/Logic/Local.hs @@ -33,8 +33,8 @@ import System.Wlog (WithLogger, logWarning) import UnliftIO (MonadUnliftIO) import Pos.Binary.Class (biSize) -import Pos.Core (BlockVersionData (bvdMaxBlockSize), HeaderHash, - ProtocolMagic, SlotId (..), slotIdF) +import Pos.Core (BlockCount, BlockVersionData (bvdMaxBlockSize), + HeaderHash, ProtocolMagic, SlotId (..), slotIdF) import Pos.Core.Update (UpId, UpdatePayload (..), UpdateProposal, UpdateVote (..)) import Pos.Crypto (PublicKey, shortHashF) @@ -125,9 +125,10 @@ processSkeleton :: , MonadReporting m ) => ProtocolMagic + -> BlockCount -> UpdatePayload -> m (Either PollVerFailure ()) -processSkeleton pm payload = +processSkeleton pm k payload = reportUnexpectedError $ withUSLock $ runExceptT $ @@ -154,7 +155,7 @@ processSkeleton pm payload = modifierOrFailure <- lift . runDBPoll . runExceptT . evalPollT msModifier . execPollT def $ do lastAdopted <- getAdoptedBV - verifyAndApplyUSPayload pm lastAdopted True (Left msSlot) payload + verifyAndApplyUSPayload pm k lastAdopted True (Left msSlot) payload case modifierOrFailure of Left failure -> throwError failure Right modifier -> do @@ -214,11 +215,13 @@ getLocalProposalNVotes id = do -- Otherwise 'Left err' is returned and 'err' lets caller decide whether -- sender could be sure that error would happen. processProposal - :: ( USLocalLogicModeWithLock ctx m - , MonadReporting m - ) - => ProtocolMagic -> UpdateProposal -> m (Either PollVerFailure ()) -processProposal pm proposal = processSkeleton pm $ UpdatePayload (Just proposal) [] + :: (USLocalLogicModeWithLock ctx m, MonadReporting m) + => ProtocolMagic + -> BlockCount + -> UpdateProposal + -> m (Either PollVerFailure ()) +processProposal pm k proposal = + processSkeleton pm k $ UpdatePayload (Just proposal) [] ---------------------------------------------------------------------------- -- Votes @@ -265,11 +268,12 @@ getLocalVote propId pk decision = do -- Otherwise 'Left err' is returned and 'err' lets caller decide whether -- sender could be sure that error would happen. processVote - :: ( USLocalLogicModeWithLock ctx m - , MonadReporting m - ) - => ProtocolMagic -> UpdateVote -> m (Either PollVerFailure ()) -processVote pm vote = processSkeleton pm $ UpdatePayload Nothing [vote] + :: (USLocalLogicModeWithLock ctx m, MonadReporting m) + => ProtocolMagic + -> BlockCount + -> UpdateVote + -> m (Either PollVerFailure ()) +processVote pm k vote = processSkeleton pm k $ UpdatePayload Nothing [vote] ---------------------------------------------------------------------------- -- Normalization and related diff --git a/update/src/Pos/Update/MemState/Types.hs b/update/src/Pos/Update/MemState/Types.hs index c065f03a77b..cc88761afd5 100644 --- a/update/src/Pos/Update/MemState/Types.hs +++ b/update/src/Pos/Update/MemState/Types.hs @@ -15,7 +15,8 @@ import Universum import Data.Default (Default (def)) import Serokell.Data.Memory.Units (Byte) -import Pos.Core (HeaderHash, SlotId (..), UpdateProposals) +import Pos.Core (HeaderHash, SlotCount, SlotId (..), UpdateProposals, + localSlotIndexMinBound) import Pos.DB.Class (MonadDBRead) import Pos.DB.GState.Common (getTip) import Pos.Infra.Slotting (MonadSlots (getCurrentSlot)) @@ -54,11 +55,10 @@ newtype MemVar = MemVar -- | Create new 'MemVar' using slotting and read-only access to DB. newMemVar - :: (MonadIO m, MonadDBRead m, MonadSlots ctx m) - => m MemVar -newMemVar = do - let slot0 = SlotId 0 minBound - msSlot <- fromMaybe slot0 <$> getCurrentSlot + :: (MonadIO m, MonadDBRead m, MonadSlots ctx m) => SlotCount -> m MemVar +newMemVar epochSlots = do + let slot0 = SlotId 0 localSlotIndexMinBound + msSlot <- fromMaybe slot0 <$> getCurrentSlot epochSlots msTip <- getTip let ms = MemState { msPool = def, msModifier = mempty, .. } liftIO $ MemVar <$> newTVarIO ms diff --git a/update/src/Pos/Update/Network/Listeners.hs b/update/src/Pos/Update/Network/Listeners.hs index 482e0f49ff0..c2131513146 100644 --- a/update/src/Pos/Update/Network/Listeners.hs +++ b/update/src/Pos/Update/Network/Listeners.hs @@ -14,24 +14,26 @@ import Universum import Formatting (build, sformat, (%)) import System.Wlog (WithLogger, logNotice, logWarning) -import Pos.Core (ProtocolMagic) +import Pos.Core (BlockCount, ProtocolMagic) import Pos.Core.Update (UpdateProposal (..), UpdateVote (..)) import Pos.Update.Logic.Local (processProposal, processVote) import Pos.Update.Mode (UpdateMode) handleProposal - :: forall ctx m . UpdateMode ctx m + :: forall ctx m + . UpdateMode ctx m => ProtocolMagic + -> BlockCount -> (UpdateProposal, [UpdateVote]) -> m Bool -handleProposal pm (proposal, votes) = do - res <- processProposal pm proposal +handleProposal pm k (proposal, votes) = do + res <- processProposal pm k proposal logProp proposal res let processed = isRight res processed <$ when processed (mapM_ processVoteLog votes) where processVoteLog :: UpdateVote -> m () - processVoteLog vote = processVote pm vote >>= logVote vote + processVoteLog vote = processVote pm k vote >>= logVote vote logVote vote (Left cause) = logWarning $ sformat ("Proposal is accepted but vote "%build% " is rejected, the reason is: "%build) @@ -55,10 +57,11 @@ handleProposal pm (proposal, votes) = do handleVote :: UpdateMode ctx m => ProtocolMagic + -> BlockCount -> UpdateVote -> m Bool -handleVote pm uv = do - res <- processVote pm uv +handleVote pm k uv = do + res <- processVote pm k uv logProcess uv res pure $ isRight res where diff --git a/update/src/Pos/Update/Poll/Logic/Apply.hs b/update/src/Pos/Update/Poll/Logic/Apply.hs index 44fc40eb62a..d79190934fb 100644 --- a/update/src/Pos/Update/Poll/Logic/Apply.hs +++ b/update/src/Pos/Update/Poll/Logic/Apply.hs @@ -16,14 +16,13 @@ import Formatting (build, builder, int, sformat, (%)) import System.Wlog (logDebug, logInfo, logNotice) import Pos.Binary.Class (biSize) -import Pos.Core (ChainDifficulty (..), Coin, EpochIndex, - HasProtocolConstants, HeaderHash, IsMainHeader (..), - ProtocolMagic, SlotId (siEpoch), SoftwareVersion (..), - addressHash, applyCoinPortionUp, blockVersionL, - coinToInteger, difficultyL, epochIndexL, flattenSlotId, - headerHashG, headerSlotL, sumCoins, unflattenSlotId, +import Pos.Core (BlockCount, ChainDifficulty (..), Coin, EpochIndex, + HeaderHash, IsMainHeader (..), ProtocolMagic, SlotCount, + SlotId (siEpoch), SoftwareVersion (..), addressHash, + applyCoinPortionUp, blockVersionL, coinToInteger, + difficultyL, epochIndexL, flattenSlotId, headerHashG, + headerSlotL, kEpochSlots, sumCoins, unflattenSlotId, unsafeIntegerToCoin) -import Pos.Core.Configuration (blkSecurityParam) import Pos.Core.Update (BlockVersion, BlockVersionData (..), UpId, UpdatePayload (..), UpdateProposal (..), UpdateVote (..), bvdUpdateProposalThd, checkUpdatePayload) @@ -62,15 +61,16 @@ type ApplyMode m = -- When it is 'Right header', it means that payload from block with -- given header is applied and in this case threshold for update proposal is -- checked. -verifyAndApplyUSPayload :: - (ApplyMode m, HasProtocolConstants) +verifyAndApplyUSPayload + :: ApplyMode m => ProtocolMagic + -> BlockCount -> BlockVersion -> Bool -> Either SlotId (Some IsMainHeader) -> UpdatePayload -> m () -verifyAndApplyUSPayload pm lastAdopted verifyAllIsKnown slotOrHeader upp@UpdatePayload {..} = do +verifyAndApplyUSPayload pm k lastAdopted verifyAllIsKnown slotOrHeader upp@UpdatePayload {..} = do -- First of all, we verify data. either (throwError . PollInvalidUpdatePayload) pure =<< runExceptT (checkUpdatePayload pm upp) whenRight slotOrHeader $ verifyHeader lastAdopted @@ -100,10 +100,12 @@ verifyAndApplyUSPayload pm lastAdopted verifyAllIsKnown slotOrHeader upp@UpdateP Left _ -> pass Right mainHeader -> do applyImplicitAgreement + (kEpochSlots k) (mainHeader ^. headerSlotL) (mainHeader ^. difficultyL) (mainHeader ^. headerHashG) applyDepthCheck + k (mainHeader ^. epochIndexL) (mainHeader ^. headerHashG) (mainHeader ^. difficultyL) @@ -287,11 +289,15 @@ verifyAndApplyVoteDo cd ups vote = do -- If proposal's total positive stake is bigger than negative, it's -- approved. Otherwise it's rejected. applyImplicitAgreement - :: (MonadPoll m, HasProtocolConstants) - => SlotId -> ChainDifficulty -> HeaderHash -> m () -applyImplicitAgreement (flattenSlotId -> slotId) cd hh = do + :: MonadPoll m + => SlotCount + -> SlotId + -> ChainDifficulty + -> HeaderHash + -> m () +applyImplicitAgreement epochSlots (flattenSlotId epochSlots -> slotId) cd hh = do BlockVersionData {..} <- getAdoptedBVData - let oldSlot = unflattenSlotId $ slotId - bvdUpdateImplicit + let oldSlot = unflattenSlotId epochSlots $ slotId - bvdUpdateImplicit -- There is no one implicit agreed proposal -- when slot of block is less than @bvdUpdateImplicit@ unless (slotId < bvdUpdateImplicit) $ @@ -318,12 +324,17 @@ applyImplicitAgreement (flattenSlotId -> slotId) cd hh = do -- confirmed or discarded (approved become confirmed, rejected become -- discarded). applyDepthCheck - :: forall m . (ApplyMode m, HasProtocolConstants) - => EpochIndex -> HeaderHash -> ChainDifficulty -> m () -applyDepthCheck epoch hh (ChainDifficulty cd) - | cd <= blkSecurityParam = pass + :: forall m + . ApplyMode m + => BlockCount + -> EpochIndex + -> HeaderHash + -> ChainDifficulty + -> m () +applyDepthCheck k epoch hh (ChainDifficulty cd) + | cd <= k = pass | otherwise = do - deepProposals <- getDeepProposals (ChainDifficulty (cd - blkSecurityParam)) + deepProposals <- getDeepProposals (ChainDifficulty (cd - k)) -- 1. Group proposals by application name -- 2. Sort proposals in each group by tuple -- (decision, whether decision is implicit, positive stake, slot when it has been proposed) diff --git a/update/src/Pos/Update/Poll/Logic/Base.hs b/update/src/Pos/Update/Poll/Logic/Base.hs index 81badff85e6..209a0cfcd29 100644 --- a/update/src/Pos/Update/Poll/Logic/Base.hs +++ b/update/src/Pos/Update/Poll/Logic/Base.hs @@ -40,11 +40,10 @@ import System.Wlog (WithLogger, logDebug, logNotice) import Pos.Binary.Update () import Pos.Core (BlockVersion (..), Coin, CoinPortion (..), - EpochIndex, HasProtocolConstants, HeaderHash, - IsMainHeader (..), SlotId, SoftforkRule (..), - TimeDiff (..), addressHash, applyCoinPortionUp, - coinPortionDenominator, coinToInteger, difficultyL, - epochSlots, getCoinPortion, headerHashG, isBootstrapEra, + EpochIndex, HeaderHash, IsMainHeader (..), SlotCount, + SlotId, SoftforkRule (..), TimeDiff (..), addressHash, + applyCoinPortionUp, coinPortionDenominator, coinToInteger, + difficultyL, getCoinPortion, headerHashG, isBootstrapEra, sumCoins, unsafeAddCoin, unsafeIntegerToCoin, unsafeSubCoin) import Pos.Core.Update (BlockVersionData (..), @@ -200,10 +199,11 @@ adoptBlockVersion winningBlk bv = do -- @SlottingData@ from the update. We can recieve updated epoch @SlottingData@ -- and from it, changed epoch/slot times, which is important to keep track of. updateSlottingData - :: (HasProtocolConstants, MonadError PollVerFailure m, MonadPoll m) - => EpochIndex + :: (MonadError PollVerFailure m, MonadPoll m) + => SlotCount + -> EpochIndex -> m () -updateSlottingData epochIndex = do +updateSlottingData epochSlots epochIndex = do let errFmt = ("can't update slotting data, stored current epoch is "%int% ", while given epoch is "%int% diff --git a/update/src/Pos/Update/Poll/Logic/Softfork.hs b/update/src/Pos/Update/Poll/Logic/Softfork.hs index 894cc42f395..b42636227c5 100644 --- a/update/src/Pos/Update/Poll/Logic/Softfork.hs +++ b/update/src/Pos/Update/Poll/Logic/Softfork.hs @@ -17,9 +17,9 @@ import Formatting (build, sformat, (%)) import Serokell.Util.Text (listJson) import System.Wlog (logInfo) -import Pos.Core (BlockVersion, Coin, EpochIndex, HasProtocolConstants, - HeaderHash, SlotId (..), SoftforkRule (..), StakeholderId, - crucialSlot, sumCoins, unsafeIntegerToCoin) +import Pos.Core (BlockCount, BlockVersion, Coin, EpochIndex, + HeaderHash, SlotCount, SlotId (..), SoftforkRule (..), + StakeholderId, crucialSlot, sumCoins, unsafeIntegerToCoin) import Pos.Core.Update (BlockVersionData (..)) import Pos.Update.Poll.Class (MonadPoll (..), MonadPollRead (..)) import Pos.Update.Poll.Failure (PollVerFailure (..)) @@ -32,13 +32,18 @@ import Pos.Util.AssertMode (inAssertMode) -- | Record the fact that main block with given version and leader has -- been issued by for the given slot. recordBlockIssuance - :: (MonadError PollVerFailure m, MonadPoll m, HasProtocolConstants) - => StakeholderId -> BlockVersion -> SlotId -> HeaderHash -> m () -recordBlockIssuance id bv slot h = do + :: (MonadError PollVerFailure m, MonadPoll m) + => BlockCount + -> StakeholderId + -> BlockVersion + -> SlotId + -> HeaderHash + -> m () +recordBlockIssuance k id bv slot h = do -- Issuance is stable if it happens before crucial slot for next epoch. -- In other words, processing genesis block for next epoch will -- inevitably encounter this issuer. - let unstable = slot > crucialSlot (siEpoch slot + 1) + let unstable = slot > crucialSlot k (siEpoch slot + 1) getBVState bv >>= \case Nothing -> unlessM ((bv ==) <$> getAdoptedBV) $ throwError noBVError Just bvs@BlockVersionState {..} @@ -71,9 +76,12 @@ recordBlockIssuance id bv slot h = do -- | Process creation of genesis block for given epoch. processGenesisBlock - :: forall m. (MonadError PollVerFailure m, MonadPoll m, HasProtocolConstants) - => EpochIndex -> m () -processGenesisBlock epoch = do + :: forall m + . (MonadError PollVerFailure m, MonadPoll m) + => SlotCount + -> EpochIndex + -> m () +processGenesisBlock epochSlots epoch = do -- First thing to do is to obtain values threshold for softfork -- resolution rule check. totalStake <- note (PollUnknownStakes epoch) =<< getEpochTotalStake epoch @@ -96,7 +104,7 @@ processGenesisBlock 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 epoch + updateSlottingData epochSlots epoch setEpochProposers mempty where checkThreshold :: diff --git a/update/src/Pos/Update/Worker.hs b/update/src/Pos/Update/Worker.hs index 638eb34579d..e2b1230fdaa 100644 --- a/update/src/Pos/Update/Worker.hs +++ b/update/src/Pos/Update/Worker.hs @@ -12,7 +12,7 @@ import Formatting (build, sformat, (%)) import Serokell.Util.Text (listJsonIndent) import System.Wlog (logDebug, logInfo) -import Pos.Core (SoftwareVersion (..)) +import Pos.Core (BlockCount, SoftwareVersion (..), kEpochSlots) import Pos.Core.Update (UpdateProposal (..)) import Pos.Infra.Diffusion.Types (Diffusion) import Pos.Infra.Recovery.Info (recoveryCommGuard) @@ -30,26 +30,23 @@ import Pos.Util.Util (lensOf) -- | Update System related workers. usWorkers - :: forall ctx m. - ( UpdateMode ctx m - ) - => [Diffusion m -> m ()] -usWorkers = [processNewSlotWorker, checkForUpdateWorker] + :: forall ctx m . UpdateMode ctx m => BlockCount -> [Diffusion m -> m ()] +usWorkers k = [processNewSlotWorker, checkForUpdateWorker] where -- These are two separate workers. We want them to run in parallel -- and not affect each other. processNewSlotParams = defaultOnNewSlotParams - { onspTerminationPolicy = - NewSlotTerminationPolicy "Update.processNewSlot" + { onspTerminationPolicy = NewSlotTerminationPolicy + "Update.processNewSlot" } - processNewSlotWorker = \_ -> - onNewSlot processNewSlotParams $ \s -> - recoveryCommGuard "processNewSlot in US" $ do + processNewSlotWorker _ = + onNewSlot (kEpochSlots k) processNewSlotParams $ \s -> + recoveryCommGuard k "processNewSlot in US" $ do logDebug "Updating slot for US..." processNewSlot s - checkForUpdateWorker = \_ -> - onNewSlot defaultOnNewSlotParams $ \_ -> - recoveryCommGuard "checkForUpdate" (checkForUpdate @ctx @m) + checkForUpdateWorker _ = + onNewSlot (kEpochSlots k) defaultOnNewSlotParams $ \_ -> + recoveryCommGuard k "checkForUpdate" (checkForUpdate @ctx @m) checkForUpdate :: forall ctx m. UpdateMode ctx m diff --git a/update/test/Test/Pos/Update/Arbitrary/Poll.hs b/update/test/Test/Pos/Update/Arbitrary/Poll.hs index 6056c9bd3b8..cee170f2200 100644 --- a/update/test/Test/Pos/Update/Arbitrary/Poll.hs +++ b/update/test/Test/Pos/Update/Arbitrary/Poll.hs @@ -18,7 +18,6 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, import Pos.Arbitrary.Slotting () import Pos.Binary.Update () -import Pos.Core.Configuration (HasProtocolConstants) import Pos.Update.Poll.Modifier (PollModifier (..)) import Pos.Update.Poll.PollState (PollState (..), psActivePropsIdx) import Pos.Update.Poll.Types (BlockVersionState (..), @@ -34,7 +33,7 @@ instance Arbitrary UpsExtra where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary UndecidedProposalState where +instance Arbitrary UndecidedProposalState where arbitrary = genericArbitrary shrink = genericShrink @@ -42,7 +41,7 @@ instance Arbitrary DpsExtra where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary DecidedProposalState where +instance Arbitrary DecidedProposalState where arbitrary = genericArbitrary shrink = genericShrink @@ -50,7 +49,7 @@ instance Arbitrary ConfirmedProposalState where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary ProposalState where +instance Arbitrary ProposalState where arbitrary = genericArbitrary shrink = genericShrink @@ -58,17 +57,17 @@ instance Arbitrary BlockVersionState where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary PollModifier where +instance Arbitrary PollModifier where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary PollState where +instance Arbitrary PollState where arbitrary = do ps <- genericArbitrary return (ps & psActivePropsIdx %~ HM.filter (not . null)) shrink = genericShrink -instance HasProtocolConstants => Arbitrary USUndo where +instance Arbitrary USUndo where arbitrary = genericArbitrary shrink = genericShrink diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index 1ea89c99d1d..ad282f4a303 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -420,7 +420,9 @@ test-suite wallet-unit-tests , cardano-sl-block , cardano-sl-client , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto + , cardano-sl-crypto-test , cardano-sl-db , cardano-sl-delegation , cardano-sl-lrc @@ -496,6 +498,7 @@ test-suite wallet-new-specs , cardano-sl-client , cardano-sl-client , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto , cardano-sl-txp , cardano-sl-util diff --git a/wallet-new/server/Main.hs b/wallet-new/server/Main.hs index 8bf971608ee..0d1c23eca22 100644 --- a/wallet-new/server/Main.hs +++ b/wallet-new/server/Main.hs @@ -13,7 +13,7 @@ import Data.Maybe (fromJust) import Mockable (Production (..), runProduction) import Ntp.Client (NtpStatus, withNtpClient) import qualified Pos.Client.CLI as CLI -import Pos.Core (epochSlots) +import Pos.Core (ProtocolConstants, pcBlkSecurityParam) import Pos.Crypto (ProtocolMagic) import Pos.DB.DB (initNodeDBs) import Pos.Infra.Diffusion.Types (Diffusion) @@ -63,20 +63,21 @@ defaultLoggerName = "node" -- | The "workhorse" responsible for starting a Cardano edge node plus a number of extra plugins. actionWithWallet :: (HasConfigurations, HasCompileInfo) => ProtocolMagic + -> ProtocolConstants -> SscParams -> NodeParams -> NtpConfiguration -> WalletBackendParams -> Production () -actionWithWallet pm sscParams nodeParams ntpConfig wArgs@WalletBackendParams {..} = +actionWithWallet pm pc sscParams nodeParams ntpConfig wArgs@WalletBackendParams {..} = bracketWalletWebDB (walletDbPath walletDbOptions) (walletRebuildDb walletDbOptions) $ \db -> bracketWalletWS $ \conn -> - bracketNodeResources nodeParams sscParams + bracketNodeResources (pcBlkSecurityParam pc) nodeParams sscParams (txpGlobalSettings pm) - (initNodeDBs pm epochSlots) $ \nr@NodeResources {..} -> do + (initNodeDBs pm pc) $ \nr@NodeResources {..} -> do syncQueue <- liftIO newTQueueIO ntpStatus <- withNtpClient (ntpClientSettings ntpConfig) - runWRealMode pm db conn syncQueue nr (mainAction ntpStatus nr) + runWRealMode pm pc db conn syncQueue nr (mainAction ntpStatus nr) where mainAction ntpStatus = runNodeWithInit ntpStatus $ do when (walletFlushDb walletDbOptions) $ do @@ -91,7 +92,7 @@ actionWithWallet pm sscParams nodeParams ntpConfig wArgs@WalletBackendParams {.. runNodeWithInit ntpStatus init' nr diffusion = do _ <- init' - runNode pm nr (plugins ntpStatus) diffusion + runNode pm pc nr (plugins ntpStatus) diffusion syncWallets :: WalletWebMode () syncWallets = do @@ -102,26 +103,28 @@ actionWithWallet pm sscParams nodeParams ntpConfig wArgs@WalletBackendParams {.. plugins :: TVar NtpStatus -> Plugins.Plugin WalletWebMode plugins ntpStatus = mconcat [ Plugins.conversation wArgs - , Plugins.legacyWalletBackend pm wArgs ntpStatus + , Plugins.legacyWalletBackend pm pc wArgs ntpStatus , Plugins.walletDocumentation wArgs , Plugins.acidCleanupWorker wArgs - , Plugins.syncWalletWorker - , Plugins.resubmitterPlugin pm + , Plugins.syncWalletWorker (pcBlkSecurityParam pc) + , Plugins.resubmitterPlugin pm pc , Plugins.notifierPlugin ] actionWithNewWallet :: (HasConfigurations, HasCompileInfo) => ProtocolMagic + -> ProtocolConstants -> SscParams -> NodeParams -> NewWalletBackendParams -> Production () -actionWithNewWallet pm sscParams nodeParams params = +actionWithNewWallet pm pc sscParams nodeParams params = bracketNodeResources + (pcBlkSecurityParam pc) nodeParams sscParams (txpGlobalSettings pm) - (initNodeDBs pm epochSlots) $ \nr -> do + (initNodeDBs pm pc) $ \nr -> do -- TODO: Will probably want to extract some parameters from the -- 'NewWalletBackendParams' to construct or initialize the wallet @@ -129,6 +132,7 @@ actionWithNewWallet pm sscParams nodeParams params = bracketKernelPassiveWallet logMessage' $ \walletLayer passiveWallet -> do liftIO $ logMessage' Info "Wallet kernel initialized" Kernel.Mode.runWalletMode pm + pc nr walletLayer (mainAction (walletLayer, passiveWallet) nr) @@ -143,7 +147,7 @@ actionWithNewWallet pm sscParams nodeParams params = :: (PassiveWalletLayer Production, PassiveWallet) -> NodeResources ext -> (Diffusion Kernel.Mode.WalletMode -> Kernel.Mode.WalletMode ()) - runNodeWithInit w nr = runNode pm nr (plugins w) + runNodeWithInit w nr = runNode pm pc nr (plugins w) -- TODO: Don't know if we need any of the other plugins that are used -- in the legacy wallet (see 'actionWithWallet'). @@ -167,13 +171,13 @@ startEdgeNode :: HasCompileInfo => WalletStartupOptions -> Production () startEdgeNode wso = - withConfigurations blPath conf $ \ntpConfig pm -> do + withConfigurations blPath conf $ \ntpConfig pm pc -> do (sscParams, nodeParams) <- getParameters ntpConfig case wsoWalletBackendParams wso of WalletLegacy legacyParams -> - actionWithWallet pm sscParams nodeParams ntpConfig legacyParams + actionWithWallet pm pc sscParams nodeParams ntpConfig legacyParams WalletNew newParams -> - actionWithNewWallet pm sscParams nodeParams newParams + actionWithNewWallet pm pc sscParams nodeParams newParams where getParameters :: HasConfigurations => NtpConfiguration -> Production (SscParams, NodeParams) getParameters ntpConfig = do diff --git a/wallet-new/src/Cardano/Wallet/API/V0/Handlers.hs b/wallet-new/src/Cardano/Wallet/API/V0/Handlers.hs index 566de55a575..7b0359ea09b 100644 --- a/wallet-new/src/Cardano/Wallet/API/V0/Handlers.hs +++ b/wallet-new/src/Cardano/Wallet/API/V0/Handlers.hs @@ -3,6 +3,7 @@ module Cardano.Wallet.API.V0.Handlers where import qualified Cardano.Wallet.API.V0 as V0 import Ntp.Client (NtpStatus) +import Pos.Core (ProtocolConstants) import Pos.Crypto (ProtocolMagic) import Pos.Infra.Diffusion.Types (Diffusion (sendTx)) import Pos.Util.CompileInfo (HasCompileInfo) @@ -20,10 +21,11 @@ import Universum handlers :: ( MonadFullWalletWebMode ctx m, HasCompileInfo ) => (forall a. m a -> Handler a) -> ProtocolMagic + -> ProtocolConstants -> Diffusion m -> TVar NtpStatus -> Server V0.API -handlers naturalTransformation pm diffusion ntpStatus = hoistServer +handlers naturalTransformation pm pc diffusion ntpStatus = hoistServer (Proxy @V0.API) naturalTransformation - (V0.servantHandlers pm ntpStatus (sendTx diffusion)) + (V0.servantHandlers pm pc ntpStatus (sendTx diffusion)) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers.hs index c225e494df4..6f582632af1 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers.hs @@ -10,6 +10,7 @@ module Cardano.Wallet.API.V1.LegacyHandlers where import Universum import Ntp.Client (NtpStatus) +import Pos.Core (ProtocolConstants, pcBlkSecurityParam) import Pos.Crypto (ProtocolMagic) import Pos.Infra.Diffusion.Types (Diffusion (sendTx)) @@ -41,13 +42,14 @@ handlers :: ( HasConfigurations ) => (forall a. MonadV1 a -> Handler a) -> ProtocolMagic + -> ProtocolConstants -> Diffusion MonadV1 -> TVar NtpStatus -> Server V1.API -handlers naturalTransformation pm diffusion ntpStatus = +handlers naturalTransformation pm pc diffusion ntpStatus = hoistServer (Proxy @Addresses.API) naturalTransformation Addresses.handlers - :<|> hoistServer (Proxy @Wallets.API) naturalTransformation Wallets.handlers + :<|> hoistServer (Proxy @Wallets.API) naturalTransformation (Wallets.handlers $ pcBlkSecurityParam pc) :<|> hoistServer (Proxy @Accounts.API) naturalTransformation Accounts.handlers - :<|> hoistServer (Proxy @Transactions.API) naturalTransformation (Transactions.handlers pm (sendTx diffusion)) + :<|> hoistServer (Proxy @Transactions.API) naturalTransformation (Transactions.handlers pm pc (sendTx diffusion)) :<|> hoistServer (Proxy @Settings.API) naturalTransformation Settings.handlers :<|> hoistServer (Proxy @Info.API) naturalTransformation (Info.handlers diffusion ntpStatus) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs index 068e9bb162f..9bf9a8d406f 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs @@ -8,7 +8,7 @@ import Servant import Pos.Client.Txp.Util (defaultInputSelectionPolicy) import qualified Pos.Client.Txp.Util as V0 -import Pos.Core (TxAux) +import Pos.Core (ProtocolConstants, TxAux) import qualified Pos.Core as Core import Pos.Crypto (ProtocolMagic) import qualified Pos.Util.Servant as V0 @@ -32,21 +32,23 @@ import Cardano.Wallet.API.V1.Types handlers :: HasConfigurations => ProtocolMagic + -> ProtocolConstants -> (TxAux -> MonadV1 Bool) -> ServerT Transactions.API MonadV1 -handlers pm submitTx = - newTransaction pm submitTx +handlers pm pc submitTx = + newTransaction pm pc submitTx :<|> allTransactions - :<|> estimateFees pm + :<|> estimateFees pm (Core.pcEpochSlots pc) newTransaction :: forall ctx m . (V0.MonadWalletTxFull ctx m) => ProtocolMagic + -> ProtocolConstants -> (TxAux -> m Bool) -> Payment -> m (WalletResponse Transaction) -newTransaction pm submitTx Payment {..} = do +newTransaction pm pc submitTx Payment {..} = do ws <- V0.askWalletSnapshot sourceWallet <- migrate (psWalletId pmtSource) @@ -69,7 +71,7 @@ newTransaction pm submitTx Payment {..} = do addrCoinList <- migrate $ NE.toList pmtDestinations let (V1 policy) = fromMaybe (V1 defaultInputSelectionPolicy) pmtGroupingPolicy let batchPayment = V0.NewBatchPayment cAccountId addrCoinList policy - cTx <- V0.newPaymentBatch pm submitTx spendingPw batchPayment + cTx <- V0.newPaymentBatch pm pc submitTx spendingPw batchPayment single <$> migrate cTx @@ -117,16 +119,17 @@ allTransactions mwalletId mAccIdx mAddr requestParams fops sops = estimateFees :: (MonadThrow m, V0.MonadFees ctx m) => ProtocolMagic + -> Core.SlotCount -> Payment -> m (WalletResponse EstimatedFees) -estimateFees pm Payment{..} = do +estimateFees pm epochSlots Payment{..} = do ws <- V0.askWalletSnapshot let (V1 policy) = fromMaybe (V1 defaultInputSelectionPolicy) pmtGroupingPolicy pendingAddrs = V0.getPendingAddresses ws policy cAccountId <- migrate pmtSource utxo <- V0.getMoneySourceUtxo ws (V0.AccountMoneySource cAccountId) outputs <- V0.coinDistrToOutputs =<< mapM migrate pmtDestinations - efee <- V0.runTxCreator policy (V0.computeTxFee pm pendingAddrs utxo outputs) + efee <- V0.runTxCreator policy (V0.computeTxFee pm epochSlots pendingAddrs utxo outputs) case efee of Right fee -> single <$> migrate fee diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs index 02ab089f731..91a57d04851 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs @@ -34,8 +34,8 @@ import Servant -- | All the @Servant@ handlers for wallet-specific operations. handlers :: HasConfigurations - => ServerT Wallets.API MonadV1 -handlers = newWallet + => Core.BlockCount -> ServerT Wallets.API MonadV1 +handlers k = newWallet k :<|> listWallets :<|> updatePassword :<|> deleteWallet @@ -50,14 +50,14 @@ handlers = newWallet -- or are struggling to keep up. Therefore we consider a node to be \"synced -- enough\" with the blockchain if we are not lagging more than @k@ slots, where -- @k@ comes from the 'blkSecurityParam'. -isNodeSufficientlySynced :: Core.HasProtocolConstants => V0.SyncProgress -> Bool -isNodeSufficientlySynced spV0 = +isNodeSufficientlySynced :: Core.BlockCount -> V0.SyncProgress -> Bool +isNodeSufficientlySynced k spV0 = let blockchainHeight = fromMaybe (Core.BlockCount maxBound) (Core.getChainDifficulty <$> V0._spNetworkCD spV0) localHeight = Core.getChainDifficulty . V0._spLocalCD $ spV0 remainingBlocks = blockchainHeight - localHeight - in remainingBlocks <= Core.blkSecurityParam + in remainingBlocks <= k -- | Creates a new or restores an existing @wallet@ given a 'NewWallet' payload. -- Returns to the client the representation of the created or restored @@ -69,16 +69,17 @@ newWallet , V0.MonadBlockchainInfo m , HasLens SyncQueue ctx SyncQueue ) - => NewWallet + => Core.BlockCount + -> NewWallet -> m (WalletResponse Wallet) -newWallet NewWallet{..} = do +newWallet k NewWallet{..} = do spV0 <- V0.syncProgress syncPercentage <- migrate spV0 -- Do not allow creation or restoration of wallets if the underlying node -- is still catching up. - unless (isNodeSufficientlySynced spV0) $ throwM (NodeIsStillSyncing syncPercentage) + unless (isNodeSufficientlySynced k spV0) $ throwM (NodeIsStillSyncing syncPercentage) let newWalletHandler CreateWallet = V0.newWallet newWalletHandler RestoreWallet = V0.restoreWalletFromSeed diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs b/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs index eb40f188351..d0575fdf873 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs @@ -89,8 +89,8 @@ walletRollbackBlocks _w _bs = do return mempty instance MonadBListener WalletMode where - onApplyBlocks bs = getWallet >>= (`walletApplyBlocks` bs) - onRollbackBlocks bs = getWallet >>= (`walletRollbackBlocks` bs) + onApplyBlocks bs = getWallet >>= (`walletApplyBlocks` bs) + onRollbackBlocks _ bs = getWallet >>= (`walletRollbackBlocks` bs) {------------------------------------------------------------------------------- Run the wallet @@ -98,12 +98,13 @@ instance MonadBListener WalletMode where runWalletMode :: forall a. (HasConfigurations, HasCompileInfo) => ProtocolMagic + -> ProtocolConstants -> NodeResources () -> PassiveWalletLayer Production -> (Diffusion WalletMode -> WalletMode a) -> Production a -runWalletMode pm nr wallet action = - Production $ runRealMode pm nr $ \diffusion -> +runWalletMode pm pc nr wallet action = + Production $ runRealMode pm pc nr $ \diffusion -> walletModeToRealMode wallet (action (hoistDiffusion realModeToWalletMode (walletModeToRealMode wallet) diffusion)) walletModeToRealMode :: forall a. PassiveWalletLayer Production -> WalletMode a -> RealMode () a @@ -183,9 +184,7 @@ instance HasConfiguration => MonadDB WalletMode where dbDelete = dbDeleteDefault dbPutSerBlunds = dbPutSerBlundsRealDefault -instance ( HasConfiguration - , MonadSlotsData ctx WalletMode - ) => MonadSlots ctx WalletMode where +instance MonadSlotsData ctx WalletMode => MonadSlots ctx WalletMode where getCurrentSlot = getCurrentSlotSimple getCurrentSlotBlocking = getCurrentSlotBlockingSimple getCurrentSlotInaccurate = getCurrentSlotInaccurateSimple diff --git a/wallet-new/src/Cardano/Wallet/LegacyServer.hs b/wallet-new/src/Cardano/Wallet/LegacyServer.hs index 545c712e34a..dbdb2b68c15 100644 --- a/wallet-new/src/Cardano/Wallet/LegacyServer.hs +++ b/wallet-new/src/Cardano/Wallet/LegacyServer.hs @@ -15,6 +15,7 @@ import qualified Cardano.Wallet.API.V1.Swagger as Swagger import Cardano.Wallet.Server.CLI (RunMode (..)) import Ntp.Client (NtpStatus) +import Pos.Core (ProtocolConstants) import Pos.Crypto (ProtocolMagic) import Pos.Infra.Diffusion.Types (Diffusion (..)) import Pos.Update.Configuration (curSoftwareVersion) @@ -28,27 +29,29 @@ import Servant walletServer :: (HasConfigurations, HasCompileInfo) => (forall a. WalletWebMode a -> Handler a) -> ProtocolMagic + -> ProtocolConstants -> Diffusion WalletWebMode -> TVar NtpStatus -> Server WalletAPI -walletServer natV0 pm diffusion ntpStatus = v0Handler :<|> v1Handler +walletServer natV0 pm pc diffusion ntpStatus = v0Handler :<|> v1Handler where - v0Handler = V0.handlers natV0 pm diffusion ntpStatus - v1Handler = V1.handlers natV0 pm diffusion ntpStatus + v0Handler = V0.handlers natV0 pm pc diffusion ntpStatus + v1Handler = V1.handlers natV0 pm pc diffusion ntpStatus walletDevServer :: (HasConfigurations, HasCompileInfo) => (forall a. WalletWebMode a -> Handler a) -> ProtocolMagic + -> ProtocolConstants -> Diffusion WalletWebMode -> TVar NtpStatus -> RunMode -> Server WalletDevAPI -walletDevServer natV0 pm diffusion ntpStatus runMode = devHandler :<|> walletHandler +walletDevServer natV0 pm pc diffusion ntpStatus runMode = devHandler :<|> walletHandler where devHandler = Dev.handlers natV0 runMode - walletHandler = walletServer natV0 pm diffusion ntpStatus + walletHandler = walletServer natV0 pm pc diffusion ntpStatus walletDocServer diff --git a/wallet-new/src/Cardano/Wallet/Server/Plugins.hs b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs index 44fec90d023..230c5ca62ac 100644 --- a/wallet-new/src/Cardano/Wallet/Server/Plugins.hs +++ b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs @@ -55,6 +55,7 @@ import qualified Servant import System.Wlog (logInfo, modifyLoggerName, usingLoggerName) import Pos.Context (HasNodeContext) +import Pos.Core (BlockCount, ProtocolConstants) import Pos.Crypto (ProtocolMagic) import Pos.Util (lensOf) @@ -122,10 +123,11 @@ walletDocumentation WalletBackendParams {..} = pure $ \_ -> -- | A @Plugin@ to start the wallet backend API. legacyWalletBackend :: (HasConfigurations, HasCompileInfo) => ProtocolMagic + -> ProtocolConstants -> WalletBackendParams -> TVar NtpStatus -> Plugin WalletWebMode -legacyWalletBackend pm WalletBackendParams {..} ntpStatus = pure $ \diffusion -> do +legacyWalletBackend pm pc WalletBackendParams {..} ntpStatus = pure $ \diffusion -> do modifyLoggerName (const "legacyServantBackend") $ do logInfo $ sformat ("Production mode for API: "%build) walletProductionApi @@ -155,6 +157,7 @@ legacyWalletBackend pm WalletBackendParams {..} ntpStatus = pure $ \diffusion -> Servant.serve API.walletDevAPI $ LegacyServer.walletDevServer (V0.convertHandler ctx) pm + pc diffusion ntpStatus walletRunMode @@ -162,6 +165,7 @@ legacyWalletBackend pm WalletBackendParams {..} ntpStatus = pure $ \diffusion -> Servant.serve API.walletAPI $ LegacyServer.walletServer (V0.convertHandler ctx) pm + pc diffusion ntpStatus @@ -237,19 +241,23 @@ walletBackend (NewWalletBackendParams WalletBackendParams{..}) (passiveLayer, pa lower env = runProduction . (`runReaderT` env) -- | A @Plugin@ to resubmit pending transactions. -resubmitterPlugin :: HasConfigurations => ProtocolMagic -> Plugin WalletWebMode -resubmitterPlugin pm = [\diffusion -> askWalletDB >>= \db -> - startPendingTxsResubmitter pm db (sendTx diffusion)] +resubmitterPlugin + :: HasConfigurations + => ProtocolMagic + -> ProtocolConstants + -> Plugin WalletWebMode +resubmitterPlugin pm pc = [\diffusion -> askWalletDB >>= \db -> + startPendingTxsResubmitter pm pc db (sendTx diffusion)] -- | A @Plugin@ to notify frontend via websockets. notifierPlugin :: HasConfigurations => Plugin WalletWebMode notifierPlugin = [const V0.notifierPlugin] -- | The @Plugin@ responsible for the restoration & syncing of a wallet. -syncWalletWorker :: HasConfigurations => Plugin WalletWebMode -syncWalletWorker = pure $ const $ +syncWalletWorker :: HasConfigurations => BlockCount -> Plugin WalletWebMode +syncWalletWorker k = pure $ const $ modifyLoggerName (const "syncWalletWorker") $ - (view (lensOf @SyncQueue) >>= processSyncRequest) + (view (lensOf @SyncQueue) >>= processSyncRequest k) -- | "Attaches" the middleware to this 'Application', if any. -- When running in debug mode, chances are we want to at least allow CORS to test the API diff --git a/wallet-new/test/DevelopmentSpec.hs b/wallet-new/test/DevelopmentSpec.hs index 89ab8b7e73e..b48338d3668 100644 --- a/wallet-new/test/DevelopmentSpec.hs +++ b/wallet-new/test/DevelopmentSpec.hs @@ -37,7 +37,7 @@ import Servant spec :: Spec spec = - withDefConfigurations $ \_ _ -> + withDefConfigurations $ \_ -> describe "development endpoint" $ describe "secret-keys" $ modifyMaxSuccess (const 10) deleteAllSecretKeysSpec diff --git a/wallet-new/test/WalletHandlersSpec.hs b/wallet-new/test/WalletHandlersSpec.hs index 1b8abb41a76..e705cf87ebf 100644 --- a/wallet-new/test/WalletHandlersSpec.hs +++ b/wallet-new/test/WalletHandlersSpec.hs @@ -8,6 +8,8 @@ import qualified Cardano.Wallet.API.V1.LegacyHandlers.Wallets as V1 import qualified Pos.Core as Core import qualified Pos.Wallet.Web.ClientTypes.Types as V0 +import Test.Pos.Core.Dummy (dummyK) + newSyncProgress :: Word64 -> Word64 -> V0.SyncProgress newSyncProgress localBlocks totalBlks = V0.SyncProgress { @@ -19,26 +21,21 @@ newSyncProgress localBlocks totalBlks = totalBlocks :: Word64 totalBlocks = 10000 -pc :: Core.ProtocolConstants -pc = Core.ProtocolConstants - { Core.pcK = 10 - , Core.pcVssMaxTTL = maxBound - , Core.pcVssMinTTL = minBound - } - spec :: Spec spec = describe "Wallet Handlers specs" $ do - describe "the 'isNodeSufficientlySynced' function " $ do - Core.withProtocolConstants pc $ do - it "should return True if we are within k blocks behind" $ do - let (Core.BlockCount k) = Core.blkSecurityParam - let progress = newSyncProgress (totalBlocks - k) totalBlocks - V1.isNodeSufficientlySynced progress `shouldBe` True - it "should return False if we are more than k blocks behind" $ do - let (Core.BlockCount k) = Core.blkSecurityParam - let progress = newSyncProgress (totalBlocks - k - 1) totalBlocks - V1.isNodeSufficientlySynced progress `shouldBe` False - it "should return False if we cannot fetch the blockchain height" $ do - let (Core.BlockCount k) = Core.blkSecurityParam - let progress = newSyncProgress (totalBlocks - k - 1) totalBlocks - V1.isNodeSufficientlySynced (progress { V0._spNetworkCD = Nothing }) `shouldBe` False + describe "the 'isNodeSufficientlySynced' function " $ do + it "should return True if we are within k blocks behind" $ do + let (Core.BlockCount k) = dummyK + let progress = newSyncProgress (totalBlocks - k) totalBlocks + V1.isNodeSufficientlySynced dummyK progress `shouldBe` True + it "should return False if we are more than k blocks behind" $ do + let (Core.BlockCount k) = dummyK + let progress = newSyncProgress (totalBlocks - k - 1) totalBlocks + V1.isNodeSufficientlySynced dummyK progress `shouldBe` False + it "should return False if we cannot fetch the blockchain height" $ do + let (Core.BlockCount k) = dummyK + let progress = newSyncProgress (totalBlocks - k - 1) totalBlocks + V1.isNodeSufficientlySynced + dummyK + (progress { V0._spNetworkCD = Nothing }) + `shouldBe` False diff --git a/wallet-new/test/unit/Test/Spec/Submission.hs b/wallet-new/test/unit/Test/Spec/Submission.hs index 79542c89cdc..70e058a7244 100644 --- a/wallet-new/test/unit/Test/Spec/Submission.hs +++ b/wallet-new/test/unit/Test/Spec/Submission.hs @@ -188,36 +188,39 @@ dependentTransactions = do outputForB <- (Core.TxOut <$> arbitrary <*> arbitrary) outputForC <- (Core.TxOut <$> arbitrary <*> arbitrary) outputForD <- (Core.TxOut <$> arbitrary <*> arbitrary) - [a,b,c,d] <- vectorOf 4 (Core.genTxAux (Core.ProtocolMagic 0)) - let a' = a { Core.taTx = (Core.taTx a) { - Core._txInputs = inputForA :| mempty - , Core._txOutputs = outputForA :| mempty - , Core._txAttributes = emptyAttributes - } - } - let b' = b { Core.taTx = (Core.taTx b) { - Core._txInputs = Core.TxInUtxo (hash (Core.taTx a')) 0 :| mempty - , Core._txOutputs = outputForB :| mempty - , Core._txAttributes = emptyAttributes - } - } - let c' = c { Core.taTx = (Core.taTx c) { - Core._txInputs = Core.TxInUtxo (hash (Core.taTx b')) 0 :| mempty - , Core._txOutputs = outputForC :| mempty - , Core._txAttributes = emptyAttributes - } - } - let d' = d { Core.taTx = (Core.taTx d) { - Core._txInputs = Core.TxInUtxo (hash (Core.taTx c')) 0 :| mempty - , Core._txOutputs = outputForD :| mempty - , Core._txAttributes = emptyAttributes - } - } - return ( LabelledTxAux "B" b' - , LabelledTxAux "C" c' - , LabelledTxAux "A" a' - , LabelledTxAux "D" d' - ) + v <- vectorOf 4 (Core.genTxAux (Core.ProtocolMagic 0)) + case v of + [a, b, c, d] -> do + let a' = a { Core.taTx = (Core.taTx a) { + Core._txInputs = inputForA :| mempty + , Core._txOutputs = outputForA :| mempty + , Core._txAttributes = emptyAttributes + } + } + let b' = b { Core.taTx = (Core.taTx b) { + Core._txInputs = Core.TxInUtxo (hash (Core.taTx a')) 0 :| mempty + , Core._txOutputs = outputForB :| mempty + , Core._txAttributes = emptyAttributes + } + } + let c' = c { Core.taTx = (Core.taTx c) { + Core._txInputs = Core.TxInUtxo (hash (Core.taTx b')) 0 :| mempty + , Core._txOutputs = outputForC :| mempty + , Core._txAttributes = emptyAttributes + } + } + let d' = d { Core.taTx = (Core.taTx d) { + Core._txInputs = Core.TxInUtxo (hash (Core.taTx c')) 0 :| mempty + , Core._txOutputs = outputForD :| mempty + , Core._txAttributes = emptyAttributes + } + } + return ( LabelledTxAux "B" b' + , LabelledTxAux "C" c' + , LabelledTxAux "A" a' + , LabelledTxAux "D" d' + ) + _ -> error "Impossible pattern match failure!" --- --- Pure generators, running in Identity diff --git a/wallet-new/test/unit/UTxO/Context.hs b/wallet-new/test/unit/UTxO/Context.hs index 7ba97399179..6dab6d08be7 100644 --- a/wallet-new/test/unit/UTxO/Context.hs +++ b/wallet-new/test/unit/UTxO/Context.hs @@ -49,6 +49,8 @@ import Pos.Crypto import Pos.Lrc.Genesis import Pos.Txp +import Test.Pos.Core.Dummy (dummyEpochSlots) + import UTxO.Crypto {------------------------------------------------------------------------------- @@ -78,7 +80,7 @@ data CardanoContext = CardanoContext { initCardanoContext :: HasConfiguration => ProtocolMagic -> CardanoContext initCardanoContext pm = CardanoContext{..} where - ccLeaders = genesisLeaders epochSlots + ccLeaders = genesisLeaders dummyEpochSlots ccStakes = genesisStakes ccBlock0 = genesisBlock0 pm (GenesisHash genesisHash) ccLeaders ccData = genesisData diff --git a/wallet-new/test/unit/UTxO/Interpreter.hs b/wallet-new/test/unit/UTxO/Interpreter.hs index 2b88162fdbb..fcc78e3c075 100644 --- a/wallet-new/test/unit/UTxO/Interpreter.hs +++ b/wallet-new/test/unit/UTxO/Interpreter.hs @@ -49,6 +49,8 @@ import UTxO.Crypto import qualified UTxO.DSL as DSL import UTxO.Translate +import Test.Pos.Core.Dummy (dummyK) + {------------------------------------------------------------------------------- Errors that may occur during interpretation -------------------------------------------------------------------------------} @@ -402,6 +404,7 @@ instance DSL.Hash h Addr => Interpret h (DSL.Block h Addr) where withConfig $ createMainBlockPure pm + dummyK blockSizeLimit prev (Just (bsiPSK, bsiLeader)) @@ -409,7 +412,7 @@ instance DSL.Hash h Addr => Interpret h (DSL.Block h Addr) where bsiKey (RawPayload (toList ts) - (defaultSscPayload (siSlot slotId)) -- TODO + (defaultSscPayload dummyK (siSlot slotId)) -- TODO dlgPayload updPayload ) diff --git a/wallet-new/test/unit/UTxO/Translate.hs b/wallet-new/test/unit/UTxO/Translate.hs index f3f6ad187d5..adcc44240ef 100644 --- a/wallet-new/test/unit/UTxO/Translate.hs +++ b/wallet-new/test/unit/UTxO/Translate.hs @@ -42,6 +42,9 @@ import UTxO.Context import UTxO.Verify (Verify) import qualified UTxO.Verify as Verify +import Test.Pos.Core.Dummy (dummyEpochSlots) +import Test.Pos.Crypto.Dummy (dummyProtocolMagic) + {------------------------------------------------------------------------------- Testing infrastructure from cardano-sl-core @@ -98,12 +101,12 @@ instance Monad m => MonadGState (TranslateT e m) where -- pure exceptions. runTranslateT :: Monad m => Exception e => TranslateT e m a -> m a runTranslateT (TranslateT ta) = - withDefConfiguration $ \pm -> + withDefConfiguration $ withDefUpdateConfiguration $ let env :: TranslateEnv env = TranslateEnv { - teContext = initContext (initCardanoContext pm) - , teProtocolMagic = pm + teContext = initContext (initCardanoContext dummyProtocolMagic) + , teProtocolMagic = dummyProtocolMagic , teConfig = Dict , teUpdate = Dict } @@ -162,16 +165,16 @@ catchSomeTranslateErrors act = do -- | Slot ID of the first block translateFirstSlot :: Monad m => TranslateT Text m SlotId translateFirstSlot = withConfig $ do - SlotId 0 <$> mkLocalSlotIndex 0 + SlotId 0 <$> mkLocalSlotIndex dummyEpochSlots 0 -- | Increment slot ID -- -- TODO: Surely a function like this must already exist somewhere? translateNextSlot :: Monad m => SlotId -> TranslateT Text m SlotId translateNextSlot (SlotId epoch lsi) = withConfig $ - case addLocalSlotIndex 1 lsi of + case addLocalSlotIndex dummyEpochSlots 1 lsi of Just lsi' -> return $ SlotId epoch lsi' - Nothing -> SlotId (epoch + 1) <$> mkLocalSlotIndex 0 + Nothing -> SlotId (epoch + 1) <$> mkLocalSlotIndex dummyEpochSlots 0 -- | Genesis block header translateGenesisHeader :: Monad m => TranslateT e m GenesisBlockHeader diff --git a/wallet-new/test/unit/UTxO/Verify.hs b/wallet-new/test/unit/UTxO/Verify.hs index 84cbf68c3ae..eb62bdd9941 100644 --- a/wallet-new/test/unit/UTxO/Verify.hs +++ b/wallet-new/test/unit/UTxO/Verify.hs @@ -37,6 +37,9 @@ import Pos.Util.Lens import qualified Pos.Util.Modifier as MM import Serokell.Util.Verify +import Test.Pos.Core.Dummy (dummyEpochSlots, dummyK, + dummyProtocolConstants) + {------------------------------------------------------------------------------- Verification environment -------------------------------------------------------------------------------} @@ -223,8 +226,7 @@ mapVerifyErrors f (Verify ma) = Verify $ mapStateT (withExceptT f) ma -- corresponding functions from the Cardano core. This didn't look very easy -- so I skipped it for now. verifyBlocksPrefix - :: HasConfiguration - => ProtocolMagic + :: ProtocolMagic -> HeaderHash -- ^ Expected tip -> Maybe SlotId -- ^ Current slot -> SlotLeaders -- ^ Slot leaders for this epoch @@ -293,8 +295,7 @@ verifyBlocksPrefix pm tip curSlot leaders lastSlots blocks = do -- * Uses 'gsAdoptedBVData' instead of 'getAdoptedBVFull' -- * Use hard-coded 'dataMustBeKnown' (instead of deriving this from 'adoptedBV') slogVerifyBlocks - :: HasConfiguration - => ProtocolMagic + :: ProtocolMagic -> Maybe SlotId -- ^ Current slot -> SlotLeaders -- ^ Slot leaders for this epoch -> LastBlkSlots -- ^ Last block slots @@ -313,12 +314,12 @@ slogVerifyBlocks pm curSlot leaders lastSlots blocks = do _ -> pass let blocksList = OldestFirst (toList (getOldestFirst blocks)) verResToMonadError formatAllErrors $ - verifyBlocks pm curSlot dataMustBeKnown adoptedBVD leaders blocksList + verifyBlocks pm dummyProtocolConstants curSlot dataMustBeKnown adoptedBVD leaders blocksList -- Here we need to compute 'SlogUndo'. When we add apply a block, -- we can remove one of the last slots stored in -- 'BlockExtra'. This removed slot must be put into 'SlogUndo'. - let toFlatSlot = fmap (flattenSlotId . view mainBlockSlot) . rightToMaybe + let toFlatSlot = fmap (flattenSlotId dummyEpochSlots . view mainBlockSlot) . rightToMaybe -- these slots will be added if we apply all blocks let newSlots = mapMaybe toFlatSlot (toList blocks) let combinedSlots :: OldestFirst [] FlatSlotId @@ -328,7 +329,7 @@ slogVerifyBlocks pm curSlot leaders lastSlots blocks = do let removedSlots :: OldestFirst [] FlatSlotId removedSlots = combinedSlots & _Wrapped %~ - (take $ length combinedSlots - fromIntegral blkSecurityParam) + (take $ length combinedSlots - fromIntegral dummyK) -- Note: here we exploit the fact that genesis block can be only 'head'. -- If we have genesis block, then size of 'newSlots' will be less than -- number of blocks we verify. It means that there will definitely diff --git a/wallet/cardano-sl-wallet.cabal b/wallet/cardano-sl-wallet.cabal index 0e0e7cbb23f..64c1de6b48c 100644 --- a/wallet/cardano-sl-wallet.cabal +++ b/wallet/cardano-sl-wallet.cabal @@ -120,6 +120,7 @@ library , cardano-sl-block , cardano-sl-client , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto , cardano-sl-delegation , cardano-sl-generator diff --git a/wallet/src/Pos/Wallet/Redirect.hs b/wallet/src/Pos/Wallet/Redirect.hs index ae44fab66a0..3229e254c03 100644 --- a/wallet/src/Pos/Wallet/Redirect.hs +++ b/wallet/src/Pos/Wallet/Redirect.hs @@ -28,8 +28,8 @@ import System.Wlog (WithLogger, logWarning) import Pos.Block.Types (LastKnownHeaderTag, MonadLastKnownHeader) import qualified Pos.Context as PC -import Pos.Core (ChainDifficulty, HasConfiguration, Timestamp, Tx, - TxAux (..), TxId, TxUndo, difficultyL, +import Pos.Core (ChainDifficulty, HasConfiguration, SlotCount, + Timestamp, Tx, TxAux (..), TxId, TxUndo, difficultyL, getCurrentTimestamp) import Pos.Core.Block (BlockHeader) import Pos.Crypto (ProtocolMagic, WithHash (..)) @@ -129,15 +129,18 @@ applyLastUpdateWebWallet = triggerShutdown ---------------------------------------------------------------------------- txpProcessTxWebWallet - :: forall ctx m . - ( TxpProcessTransactionMode ctx m - , AccountMode ctx m - , WS.WalletDbReader ctx m - ) - => ProtocolMagic -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -txpProcessTxWebWallet pm tx@(txId, txAux) = do + :: forall ctx m + . ( TxpProcessTransactionMode ctx m + , AccountMode ctx m + , WS.WalletDbReader ctx m + ) + => ProtocolMagic + -> SlotCount + -> (TxId, TxAux) + -> m (Either ToilVerFailure ()) +txpProcessTxWebWallet pm epochSlots tx@(txId, txAux) = do db <- WS.askWalletDB - txProcessTransaction pm tx >>= traverse (const $ addTxToWallets db) + txProcessTransaction pm epochSlots tx >>= traverse (const $ addTxToWallets db) where addTxToWallets :: WS.WalletDB -> m () addTxToWallets db = do @@ -162,5 +165,5 @@ txpNormalizeWebWallet :: ( TxpLocalWorkMode ctx m , MempoolExt m ~ () ) - => ProtocolMagic -> m () + => ProtocolMagic -> SlotCount -> m () txpNormalizeWebWallet = txNormalize diff --git a/wallet/src/Pos/Wallet/Web/Methods/Misc.hs b/wallet/src/Pos/Wallet/Web/Methods/Misc.hs index 52af01538a5..d3478d0f70c 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Misc.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Misc.hs @@ -46,7 +46,8 @@ import Ntp.Client (NtpStatus (..)) import Pos.Client.KeyStorage (MonadKeys (..), deleteAllSecretKeys) import Pos.Configuration (HasNodeConfiguration) -import Pos.Core (HasConfiguration, SlotId, SoftwareVersion (..)) +import Pos.Core (HasConfiguration, ProtocolConstants, SlotId, + SoftwareVersion (..), pcEpochSlots) import Pos.Crypto (hashHexF) import Pos.Infra.Shutdown (HasShutdownContext, triggerShutdown) import Pos.Infra.Slotting (MonadSlots, getCurrentSlotBlocking) @@ -214,10 +215,13 @@ dumpState = WalletStateSnapshot <$> askWalletSnapshot -- Tx resubmitting ---------------------------------------------------------------------------- -resetAllFailedPtxs :: (HasConfiguration, MonadSlots ctx m, WalletDbReader ctx m) => m NoContent -resetAllFailedPtxs = do +resetAllFailedPtxs + :: (MonadSlots ctx m, WalletDbReader ctx m) + => ProtocolConstants + -> m NoContent +resetAllFailedPtxs pc = do db <- askWalletDB - getCurrentSlotBlocking >>= resetFailedPtxs db + getCurrentSlotBlocking (pcEpochSlots pc) >>= resetFailedPtxs pc db return NoContent ---------------------------------------------------------------------------- diff --git a/wallet/src/Pos/Wallet/Web/Methods/Payment.hs b/wallet/src/Pos/Wallet/Web/Methods/Payment.hs index ad418836ec9..02f4d44cefc 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Payment.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Payment.hs @@ -29,8 +29,9 @@ import Pos.Client.Txp.Network (prepareMTx) import Pos.Client.Txp.Util (InputSelectionPolicy (..), computeTxFee, runTxCreator) import Pos.Configuration (walletTxCreationDisabled) -import Pos.Core (Address, Coin, HasConfiguration, TxAux (..), - TxOut (..), getCurrentTimestamp) +import Pos.Core (Address, Coin, HasConfiguration, ProtocolConstants, + SlotCount, TxAux (..), TxOut (..), getCurrentTimestamp, + pcEpochSlots) import Pos.Core.Txp (_txOutputs) import Pos.Crypto (PassPhrase, ProtocolMagic, SafeSigner, ShouldCheckPassphrase (..), checkPassMatches, hash, @@ -62,6 +63,7 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, getAccountAddrsOrThrow, newPayment :: MonadWalletTxFull ctx m => ProtocolMagic + -> ProtocolConstants -> (TxAux -> m Bool) -> PassPhrase -> AccountId @@ -69,7 +71,7 @@ newPayment -> Coin -> InputSelectionPolicy -> m CTx -newPayment pm submitTx passphrase srcAccount dstAddress coin policy = +newPayment pm pc submitTx passphrase srcAccount dstAddress coin policy = -- This is done for two reasons: -- 1. In order not to overflow relay. -- 2. To let other things (e. g. block processing) happen if @@ -77,6 +79,7 @@ newPayment pm submitTx passphrase srcAccount dstAddress coin policy = notFasterThan (6 :: Second) $ do sendMoney pm + pc submitTx passphrase (AccountMoneySource srcAccount) @@ -86,15 +89,17 @@ newPayment pm submitTx passphrase srcAccount dstAddress coin policy = newPaymentBatch :: MonadWalletTxFull ctx m => ProtocolMagic + -> ProtocolConstants -> (TxAux -> m Bool) -> PassPhrase -> NewBatchPayment -> m CTx -newPaymentBatch pm submitTx passphrase NewBatchPayment {..} = do +newPaymentBatch pm pc submitTx passphrase NewBatchPayment {..} = do src <- decodeCTypeOrFail npbFrom notFasterThan (6 :: Second) $ do sendMoney pm + pc submitTx passphrase (AccountMoneySource src) @@ -112,20 +117,25 @@ type MonadFees ctx m = ) getTxFee - :: MonadFees ctx m - => ProtocolMagic - -> AccountId - -> CId Addr - -> Coin - -> InputSelectionPolicy - -> m CCoin -getTxFee pm srcAccount dstAccount coin policy = do + :: MonadFees ctx m + => ProtocolMagic + -> SlotCount + -> AccountId + -> CId Addr + -> Coin + -> InputSelectionPolicy + -> m CCoin +getTxFee pm epochSlots srcAccount dstAccount coin policy = do ws <- askWalletSnapshot let pendingAddrs = getPendingAddresses ws policy - utxo <- getMoneySourceUtxo ws (AccountMoneySource srcAccount) - outputs <- coinDistrToOutputs $ one (dstAccount, coin) - TxFee fee <- rewrapTxError "Cannot compute transaction fee" $ - eitherToThrow =<< runTxCreator policy (computeTxFee pm pendingAddrs utxo outputs) + utxo <- getMoneySourceUtxo ws (AccountMoneySource srcAccount) + outputs <- coinDistrToOutputs $ one (dstAccount, coin) + TxFee fee <- + rewrapTxError "Cannot compute transaction fee" + $ eitherToThrow + =<< runTxCreator + policy + (computeTxFee pm epochSlots pendingAddrs utxo outputs) pure $ encodeCType fee data MoneySource @@ -173,13 +183,14 @@ getMoneySourceUtxo ws = sendMoney :: (MonadWalletTxFull ctx m) => ProtocolMagic + -> ProtocolConstants -> (TxAux -> m Bool) -> PassPhrase -> MoneySource -> NonEmpty (CId Addr, Coin) -> InputSelectionPolicy -> m CTx -sendMoney pm submitTx passphrase moneySource dstDistr policy = do +sendMoney pm pc submitTx passphrase moneySource dstDistr policy = do db <- askWalletDB ws <- getWalletSnapshot db when walletTxCreationDisabled $ @@ -219,7 +230,7 @@ sendMoney pm submitTx passphrase moneySource dstDistr policy = do let pendingAddrs = getPendingAddresses ws policy th <- rewrapTxError "Cannot send transaction" $ do (txAux, inpTxOuts') <- - prepareMTx pm getSigner pendingAddrs policy srcAddrs outputs (relatedAccount, passphrase) + prepareMTx pm (pcEpochSlots pc) getSigner pendingAddrs policy srcAddrs outputs (relatedAccount, passphrase) ts <- Just <$> getCurrentTimestamp let tx = taTx txAux @@ -228,9 +239,9 @@ sendMoney pm submitTx passphrase moneySource dstDistr policy = do dstAddrs = map txOutAddress . toList $ _txOutputs tx th = THEntry txHash tx Nothing inpTxOuts dstAddrs ts - ptx <- mkPendingTx ws srcWallet txHash txAux th + ptx <- mkPendingTx pc ws srcWallet txHash txAux th - th <$ submitAndSaveNewPtx pm db submitTx ptx + th <$ submitAndSaveNewPtx pm pc db submitTx ptx -- We add TxHistoryEntry's meta created by us in advance -- to make TxHistoryEntry in CTx consistent with entry in history. diff --git a/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs b/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs index e59dc0717a2..bc0cbc22c43 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs @@ -14,7 +14,8 @@ import qualified Serokell.Util.Base64 as B64 import Pos.Client.Txp.History (TxHistoryEntry (..)) import Pos.Client.Txp.Network (prepareRedemptionTx) -import Pos.Core (TxAux (..), TxOut (..), getCurrentTimestamp) +import Pos.Core (ProtocolConstants, TxAux (..), TxOut (..), + getCurrentTimestamp) import Pos.Crypto (PassPhrase, ProtocolMagic, aesDecrypt, hash, redeemDeterministicKeyGen) import Pos.Util (maybeThrow) @@ -36,12 +37,17 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, getWalletAddrsDetector) redeemAda :: MonadWalletTxFull ctx m - => ProtocolMagic -> (TxAux -> m Bool) -> PassPhrase -> CWalletRedeem -> m CTx -redeemAda pm submitTx passphrase CWalletRedeem {..} = do + => ProtocolMagic + -> ProtocolConstants + -> (TxAux -> m Bool) + -> PassPhrase + -> CWalletRedeem + -> m CTx +redeemAda pm pc submitTx passphrase CWalletRedeem {..} = do seedBs <- maybe invalidBase64 pure -- NOTE: this is just safety measure $ rightToMaybe (B64.decode crSeed) <|> rightToMaybe (B64.decodeUrl crSeed) - redeemAdaInternal pm submitTx passphrase crWalletId seedBs + redeemAdaInternal pm pc submitTx passphrase crWalletId seedBs where invalidBase64 = throwM . RequestError $ "Seed is invalid base64(url) string: " <> crSeed @@ -52,17 +58,18 @@ redeemAda pm submitTx passphrase CWalletRedeem {..} = do redeemAdaPaperVend :: MonadWalletTxFull ctx m => ProtocolMagic + -> ProtocolConstants -> (TxAux -> m Bool) -> PassPhrase -> CPaperVendWalletRedeem -> m CTx -redeemAdaPaperVend pm submitTx passphrase CPaperVendWalletRedeem {..} = do +redeemAdaPaperVend pm pc submitTx passphrase CPaperVendWalletRedeem {..} = do seedEncBs <- maybe invalidBase58 pure $ decodeBase58 bitcoinAlphabet $ encodeUtf8 pvSeed let aesKey = mnemonicToAesKey (bpToList pvBackupPhrase) seedDecBs <- either decryptionFailed pure $ aesDecrypt seedEncBs aesKey - redeemAdaInternal pm submitTx passphrase pvWalletId seedDecBs + redeemAdaInternal pm pc submitTx passphrase pvWalletId seedDecBs where invalidBase58 = throwM . RequestError $ "Seed is invalid base58 string: " <> pvSeed @@ -73,12 +80,13 @@ redeemAdaPaperVend pm submitTx passphrase CPaperVendWalletRedeem {..} = do redeemAdaInternal :: MonadWalletTxFull ctx m => ProtocolMagic + -> ProtocolConstants -> (TxAux -> m Bool) -> PassPhrase -> CAccountId -> ByteString -> m CTx -redeemAdaInternal pm submitTx passphrase cAccId seedBs = do +redeemAdaInternal pm pc submitTx passphrase cAccId seedBs = do (_, redeemSK) <- maybeThrow (RequestError "Seed is not 32-byte long") $ redeemDeterministicKeyGen seedBs accId <- decodeCTypeOrFail cAccId @@ -99,9 +107,9 @@ redeemAdaInternal pm submitTx passphrase cAccId seedBs = do txInputs = [TxOut redeemAddress redeemBalance] th = THEntry txHash tx Nothing txInputs [dstAddr] ts dstWallet = aiWId accId - ptx <- mkPendingTx ws dstWallet txHash txAux th + ptx <- mkPendingTx pc ws dstWallet txHash txAux th - th <$ submitAndSaveNewPtx pm db submitTx ptx + th <$ submitAndSaveNewPtx pm pc db submitTx ptx -- add redemption transaction to the history of new wallet let cWalId = aiWId accId diff --git a/wallet/src/Pos/Wallet/Web/Methods/Txp.hs b/wallet/src/Pos/Wallet/Web/Methods/Txp.hs index bd804fbff81..3b07528c738 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Txp.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Txp.hs @@ -22,6 +22,7 @@ import Pos.Client.KeyStorage (MonadKeys) import Pos.Client.Txp.Addresses (MonadAddresses (..)) import Pos.Client.Txp.Util (InputSelectionPolicy (..), PendingAddresses (..), isCheckedTxError) +import Pos.Core (ProtocolConstants) import Pos.Core.Chrono (getNewestFirst, toNewestFirst) import Pos.Core.Common (Coin) import Pos.Core.Txp (Tx (..), TxAux (..), TxOut (..), TxOutAux (..)) @@ -74,12 +75,13 @@ coinDistrToOutputs distr = do submitAndSaveNewPtx :: TxSubmissionMode ctx m => ProtocolMagic + -> ProtocolConstants -> WalletDB -> (TxAux -> m Bool) -> PendingTx -> m () -submitAndSaveNewPtx pm db submit = - submitAndSavePtx pm db submit ptxFirstSubmissionHandler +submitAndSaveNewPtx pm pc db submit = + submitAndSavePtx pm pc db submit ptxFirstSubmissionHandler gatherPendingTxsSummary :: MonadWalletWebMode ctx m => m [PendingTxsSummary] gatherPendingTxsSummary = diff --git a/wallet/src/Pos/Wallet/Web/Mode.hs b/wallet/src/Pos/Wallet/Web/Mode.hs index 8511cd02b6b..cab11be5c53 100644 --- a/wallet/src/Pos/Wallet/Web/Mode.hs +++ b/wallet/src/Pos/Wallet/Web/Mode.hs @@ -236,9 +236,7 @@ type MonadFullWalletWebMode ctx m = -- Instances for WalletWebMode ---------------------------------------------------------------------------- -instance (HasConfiguration, MonadSlotsData ctx WalletWebMode) - => MonadSlots ctx WalletWebMode - where +instance MonadSlotsData ctx WalletWebMode => MonadSlots ctx WalletWebMode where getCurrentSlot = getCurrentSlotSimple getCurrentSlotBlocking = getCurrentSlotBlockingSimple getCurrentSlotInaccurate = getCurrentSlotInaccurateSimple @@ -355,5 +353,5 @@ instance (HasConfigurations) type AddrData Pos.Wallet.Web.Mode.WalletWebMode = (AccountId, PassPhrase) -- We rely on the fact that Daedalus always uses HD addresses with -- BootstrapEra distribution. - getFakeChangeAddress = pure largestHDAddressBoot - getNewAddress = getNewAddressWebWallet + getFakeChangeAddress _ = pure largestHDAddressBoot + getNewAddress _ = getNewAddressWebWallet diff --git a/wallet/src/Pos/Wallet/Web/Pending/Functions.hs b/wallet/src/Pos/Wallet/Web/Pending/Functions.hs index 11e5637854a..757ef9569b5 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Functions.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Functions.hs @@ -17,7 +17,7 @@ import Universum import Formatting (build, sformat, (%)) import Pos.Client.Txp.History (SaveTxException (..), TxHistoryEntry) -import Pos.Core (HasConfiguration, protocolConstants) +import Pos.Core (ProtocolConstants, pcEpochSlots) import Pos.Core.Txp (TxAux (..), TxId) import Pos.Infra.Slotting.Class (MonadSlots (..)) import Pos.Txp (ToilVerFailure (..)) @@ -45,23 +45,28 @@ isPtxInBlocks :: PtxCondition -> Bool isPtxInBlocks = isNothing . ptxPoolInfo mkPendingTx - :: (HasConfiguration, MonadThrow m, MonadSlots ctx m) - => WalletSnapshot - -> CId Wal -> TxId -> TxAux -> TxHistoryEntry -> m PendingTx -mkPendingTx ws wid _ptxTxId _ptxTxAux th = do + :: (MonadThrow m, MonadSlots ctx m) + => ProtocolConstants + -> WalletSnapshot + -> CId Wal + -> TxId + -> TxAux + -> TxHistoryEntry + -> m PendingTx +mkPendingTx pc ws wid _ptxTxId _ptxTxAux th = do void $ maybeThrow noWallet $ getWalletMeta ws wid - _ptxCreationSlot <- getCurrentSlotInaccurate + _ptxCreationSlot <- getCurrentSlotInaccurate $ pcEpochSlots pc return PendingTx - { _ptxCond = PtxCreating th - , _ptxWallet = wid - , _ptxPeerAck = False - , _ptxSubmitTiming = mkPtxSubmitTiming protocolConstants _ptxCreationSlot + { _ptxCond = PtxCreating th + , _ptxWallet = wid + , _ptxPeerAck = False + , _ptxSubmitTiming = mkPtxSubmitTiming pc _ptxCreationSlot , .. } where noWallet = - RequestError $ sformat ("Failed to get meta of wallet "%build) wid + RequestError $ sformat ("Failed to get meta of wallet " % build) wid -- | Whether formed transaction ('TxAux') has reasonable chances to be applied -- later after specified error. diff --git a/wallet/src/Pos/Wallet/Web/Pending/Submission.hs b/wallet/src/Pos/Wallet/Web/Pending/Submission.hs index d70b7a25dcf..66ac0c0e2d9 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Submission.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Submission.hs @@ -23,7 +23,8 @@ import System.Wlog (WithLogger, logDebug, logInfo) import Pos.Client.Txp.History (saveTx, thTimestamp) import Pos.Client.Txp.Network (TxMode) import Pos.Configuration (walletTxCreationDisabled) -import Pos.Core (diffTimestamp, getCurrentTimestamp) +import Pos.Core (ProtocolConstants, diffTimestamp, + getCurrentTimestamp, pcEpochSlots) import Pos.Core.Txp (TxAux) import Pos.Crypto (ProtocolMagic) import Pos.Infra.Util.LogSafe (buildSafe, logInfoSP, logWarningSP, @@ -109,12 +110,13 @@ type TxSubmissionMode ctx m = ( TxMode m ) submitAndSavePtx :: TxSubmissionMode ctx m => ProtocolMagic + -> ProtocolConstants -> WalletDB -> (TxAux -> m Bool) -> PtxSubmissionHandlers m -> PendingTx -> m () -submitAndSavePtx pm db submitTx PtxSubmissionHandlers{..} ptx@PendingTx{..} = do +submitAndSavePtx pm pc db submitTx PtxSubmissionHandlers{..} ptx@PendingTx{..} = do -- this should've been checked before, but just in case when walletTxCreationDisabled $ throwM $ InternalError "Transaction creation is disabled by configuration!" @@ -132,7 +134,7 @@ submitAndSavePtx pm db submitTx PtxSubmissionHandlers{..} ptx@PendingTx{..} = do _ptxTxId | otherwise -> do addOnlyNewPendingTx db ptx - (saveTx pm (_ptxTxId, _ptxTxAux) + (saveTx pm (pcEpochSlots pc) (_ptxTxId, _ptxTxAux) `catches` handlers) `onException` creationFailedHandler ack <- submitTx _ptxTxAux @@ -140,7 +142,7 @@ submitAndSavePtx pm db submitTx PtxSubmissionHandlers{..} ptx@PendingTx{..} = do poolInfo <- badInitPtxCondition `maybeThrow` ptxPoolInfo _ptxCond _ <- usingPtxCoords (casPtxCondition db) ptx _ptxCond (PtxApplying poolInfo) - when ack $ ptxUpdateMeta db _ptxWallet _ptxTxId PtxMarkAcknowledged + when ack $ ptxUpdateMeta pc db _ptxWallet _ptxTxId PtxMarkAcknowledged where handlers = [ Handler $ \e -> diff --git a/wallet/src/Pos/Wallet/Web/Pending/Util.hs b/wallet/src/Pos/Wallet/Web/Pending/Util.hs index 2b305e07980..01d24bf699e 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Util.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Util.hs @@ -18,7 +18,7 @@ import Data.Reflection (give) import qualified Data.Set as Set import Pos.Client.Txp.Util (PendingAddresses (..)) -import Pos.Core (ProtocolConstants (..)) +import Pos.Core (ProtocolConstants (..), pcEpochSlots) import Pos.Core.Chrono (OldestFirst (..)) import Pos.Core.Common (Address) import Pos.Core.Slotting (FlatSlotId, SlotId, flatSlotId) @@ -29,13 +29,13 @@ import Pos.Wallet.Web.Pending.Types (PendingTx (..), pstNextSlot, ptxPeerAck, ptxSubmitTiming) mkPtxSubmitTiming :: ProtocolConstants -> SlotId -> PtxSubmitTiming -mkPtxSubmitTiming pc creationSlot = give pc $ - PtxSubmitTiming - { _pstNextSlot = creationSlot & flatSlotId +~ initialSubmitDelay +mkPtxSubmitTiming pc creationSlot = give pc $ PtxSubmitTiming + { _pstNextSlot = creationSlot + & flatSlotId (pcEpochSlots pc) + +~ initialSubmitDelay , _pstNextDelay = 1 } - where - initialSubmitDelay = 3 :: FlatSlotId + where initialSubmitDelay = 3 :: FlatSlotId -- | Sort pending transactions as close as possible to chronological order. sortPtxsChrono :: [PendingTx] -> OldestFirst [] PendingTx @@ -50,7 +50,7 @@ incPtxSubmitTimingPure -> PtxSubmitTiming incPtxSubmitTimingPure pc = give pc $ execState $ do curDelay <- pstNextDelay <<*= 2 - pstNextSlot . flatSlotId += curDelay + pstNextSlot . flatSlotId (pcEpochSlots pc) += curDelay ptxMarkAcknowledgedPure :: PendingTx -> PendingTx ptxMarkAcknowledgedPure = execState $ do diff --git a/wallet/src/Pos/Wallet/Web/Pending/Worker.hs b/wallet/src/Pos/Wallet/Web/Pending/Worker.hs index 1371a0c48b1..10ea2b9ef8a 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Worker.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Worker.hs @@ -21,8 +21,8 @@ import Pos.Client.Txp.Addresses (MonadAddresses) import Pos.Client.Txp.Network (TxMode) import Pos.Configuration (HasNodeConfiguration, pendingTxResubmitionPeriod, walletTxCreationDisabled) -import Pos.Core (ChainDifficulty (..), SlotId (..), TxAux, - difficultyL) +import Pos.Core (ChainDifficulty (..), ProtocolConstants, SlotId (..), + TxAux, difficultyL, pcEpochSlots) import Pos.Core.Chrono (getOldestFirst) import Pos.Core.Configuration (HasConfiguration) import Pos.Crypto (ProtocolMagic) @@ -72,43 +72,51 @@ processPtxInNewestBlocks db PendingTx{..} = do longAgo depth (ChainDifficulty ptxDiff) (ChainDifficulty tipDiff) = ptxDiff + depth <= tipDiff -resubmitTx :: MonadPendings ctx m - => ProtocolMagic - -> WalletDB - -> (TxAux -> m Bool) - -> PendingTx - -> m () -resubmitTx pm db submitTx ptx = - handleAny (\_ -> pass) $ do - logInfoSP $ \sl -> sformat ("Resubmitting tx "%secretOnlyF sl build) (_ptxTxId ptx) - let submissionH = ptxResubmissionHandler db ptx - submitAndSavePtx pm db submitTx submissionH ptx - updateTiming +resubmitTx + :: MonadPendings ctx m + => ProtocolMagic + -> ProtocolConstants + -> WalletDB + -> (TxAux -> m Bool) + -> PendingTx + -> m () +resubmitTx pm pc db submitTx ptx = handleAny (\_ -> pass) $ do + logInfoSP $ \sl -> + sformat ("Resubmitting tx " % secretOnlyF sl build) (_ptxTxId ptx) + let submissionH = ptxResubmissionHandler db ptx + submitAndSavePtx pm pc db submitTx submissionH ptx + updateTiming where - reportNextCheckTime time = - logInfoSP $ \sl -> - sformat ("Next resubmission of transaction "%secretOnlyF sl build%" is scheduled at " - %build) (_ptxTxId ptx) time + reportNextCheckTime time = logInfoSP $ \sl -> sformat + ( "Next resubmission of transaction " + % secretOnlyF sl build + % " is scheduled at " + % build + ) + (_ptxTxId ptx) + time updateTiming = do - usingPtxCoords (ptxUpdateMeta db) ptx PtxIncSubmitTiming + usingPtxCoords (ptxUpdateMeta pc db) ptx PtxIncSubmitTiming ws <- getWalletSnapshot db - let nextCheck = view ptxNextSubmitSlot <$> usingPtxCoords (getPendingTx ws) ptx + let nextCheck = + view ptxNextSubmitSlot <$> usingPtxCoords (getPendingTx ws) ptx whenJust nextCheck reportNextCheckTime -- | Distributes pending txs submition over current slot ~evenly resubmitPtxsDuringSlot :: MonadPendings ctx m => ProtocolMagic + -> ProtocolConstants -> WalletDB -> (TxAux -> m Bool) -> [PendingTx] -> m () -resubmitPtxsDuringSlot pm db submitTx ptxs = do +resubmitPtxsDuringSlot pm pc db submitTx ptxs = do interval <- evalSubmitDelay (length ptxs) void . forConcurrently (enumerate ptxs) $ \(i, ptx) -> do delay (interval * i) - resubmitTx pm db submitTx ptx + resubmitTx pm pc db submitTx ptx where submitionEta = 5 :: Second evalSubmitDelay toResubmitNum = do @@ -120,12 +128,13 @@ resubmitPtxsDuringSlot pm db submitTx ptxs = do processPtxsToResubmit :: MonadPendings ctx m => ProtocolMagic + -> ProtocolConstants -> WalletDB -> (TxAux -> m Bool) -> SlotId -> [PendingTx] -> m () -processPtxsToResubmit pm db submitTx _curSlot ptxs = do +processPtxsToResubmit pm pc db submitTx _curSlot ptxs = do ptxsPerSlotLimit <- evalPtxsPerSlotLimit let toResubmit = take (min 1 ptxsPerSlotLimit) $ -- for now the limit will be 1, @@ -138,7 +147,7 @@ processPtxsToResubmit pm db submitTx _curSlot ptxs = do logInfoSP $ \sl -> sformat (fmt sl) (map _ptxTxId toResubmit) when (null toResubmit) $ logDebug "There are no transactions to resubmit" - resubmitPtxsDuringSlot pm db submitTx toResubmit + resubmitPtxsDuringSlot pm pc db submitTx toResubmit where fmt sl = "Transactions to resubmit on current slot: "%secureListF sl listJson evalPtxsPerSlotLimit = do @@ -155,40 +164,43 @@ processPtxsToResubmit pm db submitTx _curSlot ptxs = do processPtxs :: MonadPendings ctx m => ProtocolMagic + -> ProtocolConstants -> WalletDB -> (TxAux -> m Bool) -> SlotId -> [PendingTx] -> m () -processPtxs pm db submitTx curSlot ptxs = do +processPtxs pm pc db submitTx curSlot ptxs = do mapM_ (processPtxInNewestBlocks db) ptxs if walletTxCreationDisabled then logDebug "Transaction resubmission is disabled" - else processPtxsToResubmit pm db submitTx curSlot ptxs + else processPtxsToResubmit pm pc db submitTx curSlot ptxs processPtxsOnSlot :: MonadPendings ctx m => ProtocolMagic + -> ProtocolConstants -> WalletDB -> (TxAux -> m Bool) -> SlotId -> m () -processPtxsOnSlot pm db submitTx curSlot = do +processPtxsOnSlot pm pc db submitTx curSlot = do ws <- getWalletSnapshot db let ptxs = getPendingTxs ws let sortedPtxs = getOldestFirst $ sortPtxsChrono ptxs - processPtxs pm db submitTx curSlot sortedPtxs + processPtxs pm pc db submitTx curSlot sortedPtxs -- | On each slot this takes several pending transactions and resubmits them if -- needed and possible. startPendingTxsResubmitter :: MonadPendings ctx m => ProtocolMagic + -> ProtocolConstants -> WalletDB -> (TxAux -> m Bool) -> m () -startPendingTxsResubmitter pm db submitTx = - setLogger $ onNewSlot onsp (processPtxsOnSlot pm db submitTx) +startPendingTxsResubmitter pm pc db submitTx = setLogger + $ onNewSlot (pcEpochSlots pc) onsp (processPtxsOnSlot pm pc db submitTx) where setLogger = modifyLoggerName (<> "tx" <> "resubmitter") onsp :: OnNewSlotParams diff --git a/wallet/src/Pos/Wallet/Web/Server/Handlers.hs b/wallet/src/Pos/Wallet/Web/Server/Handlers.hs index f1b42d6ccd3..cbd80dbeb3f 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Handlers.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Handlers.hs @@ -18,6 +18,7 @@ import Servant.Generic (AsServerT, GenericProduct, ToServant, import Servant.Server (Handler, Server, ServerT, hoistServer) import Servant.Swagger.UI (swaggerSchemaUIServer) +import Pos.Core (ProtocolConstants, pcEpochSlots) import Pos.Core.Txp (TxAux) import Pos.Crypto (ProtocolMagic) import Pos.Update.Configuration (curSoftwareVersion) @@ -38,12 +39,13 @@ servantHandlersWithSwagger , HasCompileInfo ) => ProtocolMagic + -> ProtocolConstants -> TVar NtpStatus -> (TxAux -> m Bool) -> (forall x. m x -> Handler x) -> Server A.WalletSwaggerApi -servantHandlersWithSwagger pm ntpStatus submitTx nat = - hoistServer A.walletApi nat (servantHandlers pm ntpStatus submitTx) +servantHandlersWithSwagger pm pc ntpStatus submitTx nat = + hoistServer A.walletApi nat (servantHandlers pm pc ntpStatus submitTx) :<|> swaggerSchemaUIServer swaggerSpecForWalletApi @@ -56,18 +58,19 @@ servantHandlers , HasCompileInfo ) => ProtocolMagic + -> ProtocolConstants -> TVar NtpStatus -> (TxAux -> m Bool) -> ServerT A.WalletApi m -servantHandlers pm ntpStatus submitTx = toServant' A.WalletApiRecord +servantHandlers pm pc ntpStatus submitTx = toServant' A.WalletApiRecord { _test = testHandlers , _wallets = walletsHandlers , _accounts = accountsHandlers , _addresses = addressesHandlers , _profile = profileHandlers - , _txs = txsHandlers pm submitTx + , _txs = txsHandlers pm pc submitTx , _update = updateHandlers - , _redemptions = redemptionsHandlers pm submitTx + , _redemptions = redemptionsHandlers pm pc submitTx , _reporting = reportingHandlers , _settings = settingsHandlers ntpStatus , _backup = backupHandlers @@ -119,13 +122,14 @@ profileHandlers = toServant' A.WProfileApiRecord txsHandlers :: MonadFullWalletWebMode ctx m => ProtocolMagic + -> ProtocolConstants -> (TxAux -> m Bool) -> ServerT A.WTxsApi m -txsHandlers pm submitTx = toServant' A.WTxsApiRecord - { _newPayment = M.newPayment pm submitTx - , _newPaymentBatch = M.newPaymentBatch pm submitTx - , _txFee = M.getTxFee pm - , _resetFailedPtxs = M.resetAllFailedPtxs +txsHandlers pm pc submitTx = toServant' A.WTxsApiRecord + { _newPayment = M.newPayment pm pc submitTx + , _newPaymentBatch = M.newPaymentBatch pm pc submitTx + , _txFee = M.getTxFee pm (pcEpochSlots pc) + , _resetFailedPtxs = M.resetAllFailedPtxs pc , _cancelApplyingPtxs = M.cancelAllApplyingPtxs , _cancelSpecificApplyingPtx = M.cancelOneApplyingPtx , _getHistory = M.getHistoryLimited @@ -142,11 +146,12 @@ updateHandlers = toServant' A.WUpdateApiRecord redemptionsHandlers :: MonadFullWalletWebMode ctx m => ProtocolMagic + -> ProtocolConstants -> (TxAux -> m Bool) -> ServerT A.WRedemptionsApi m -redemptionsHandlers pm submitTx = toServant' A.WRedemptionsApiRecord - { _redeemADA = M.redeemAda pm submitTx - , _redeemADAPaperVend = M.redeemAdaPaperVend pm submitTx +redemptionsHandlers pm pc submitTx = toServant' A.WRedemptionsApiRecord + { _redeemADA = M.redeemAda pm pc submitTx + , _redeemADAPaperVend = M.redeemAdaPaperVend pm pc submitTx } reportingHandlers :: MonadFullWalletWebMode ctx m => ServerT A.WReportingApi m diff --git a/wallet/src/Pos/Wallet/Web/Server/Launcher.hs b/wallet/src/Pos/Wallet/Web/Server/Launcher.hs index 55fa531cb4d..2c031adff20 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Launcher.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Launcher.hs @@ -30,6 +30,7 @@ import Ntp.Client (NtpStatus) import Pos.Client.Txp.Network (sendTxOuts) import Pos.Communication (OutSpecs) +import Pos.Core (ProtocolConstants) import Pos.Crypto (ProtocolMagic) import Pos.Infra.Diffusion.Types (Diffusion (sendTx)) import Pos.Infra.Util.TimeWarp (NetworkAddress) @@ -80,16 +81,17 @@ walletApplication serv = do upgradeApplicationWS wsConn . serve swaggerWalletApi <$> serv walletServer - :: forall ctx m. - ( MonadFullWalletWebMode ctx m, HasCompileInfo ) + :: forall ctx m + . (MonadFullWalletWebMode ctx m, HasCompileInfo) => ProtocolMagic + -> ProtocolConstants -> Diffusion m -> TVar NtpStatus - -> (forall x. m x -> Handler x) + -> (forall x . m x -> Handler x) -> m (Server WalletSwaggerApi) -walletServer pm diffusion ntpStatus nat = do +walletServer pm pc diffusion ntpStatus nat = do mapM_ (findKey >=> syncWallet . eskToWalletDecrCredentials) =<< myRootAddresses - return $ servantHandlersWithSwagger pm ntpStatus submitTx nat + return $ servantHandlersWithSwagger pm pc ntpStatus submitTx nat where -- Diffusion layer takes care of submitting transactions. submitTx = sendTx diffusion diff --git a/wallet/src/Pos/Wallet/Web/Server/Runner.hs b/wallet/src/Pos/Wallet/Web/Server/Runner.hs index 2854dbe18eb..c7af32bc696 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Runner.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Runner.hs @@ -26,6 +26,7 @@ import Servant.Server (Handler) import System.Wlog (logInfo, usingLoggerName) import Cardano.NodeIPC (startNodeJsIPC) +import Pos.Core (ProtocolConstants) import Pos.Crypto (ProtocolMagic) import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion) import Pos.Infra.Shutdown.Class (HasShutdownContext (shutdownContext)) @@ -49,19 +50,18 @@ import Pos.Web (TlsParams) -- | 'WalletWebMode' runner. runWRealMode - :: forall a . - ( HasConfigurations - , HasCompileInfo - ) + :: forall a + . (HasConfigurations, HasCompileInfo) => ProtocolMagic + -> ProtocolConstants -> WalletDB -> ConnectionsVar -> SyncQueue -> NodeResources WalletMempoolExt -> (Diffusion WalletWebMode -> WalletWebMode a) -> Production a -runWRealMode pm db conn syncRequests res action = Production $ - runRealMode pm res $ \diffusion -> +runWRealMode pm pc db conn syncRequests res action = Production $ + runRealMode pm pc res $ \diffusion -> walletWebModeToRealMode db conn syncRequests $ action (hoistDiffusion realModeToWalletWebMode (walletWebModeToRealMode db conn syncRequests) diffusion) @@ -70,13 +70,14 @@ walletServeWebFull , HasCompileInfo ) => ProtocolMagic + -> ProtocolConstants -> Diffusion WalletWebMode -> TVar NtpStatus -> Bool -- ^ whether to include genesis keys -> NetworkAddress -- ^ IP and Port to listen -> Maybe TlsParams -> WalletWebMode () -walletServeWebFull pm diffusion ntpStatus debug address mTlsParams = do +walletServeWebFull pm pc diffusion ntpStatus debug address mTlsParams = do ctx <- view shutdownContext let portCallback :: Word16 -> IO () @@ -90,7 +91,7 @@ walletServeWebFull pm diffusion ntpStatus debug address mTlsParams = do wwmc <- walletWebModeContext walletApplication $ - walletServer @WalletWebModeContext @WalletWebMode pm diffusion ntpStatus (convertHandler wwmc) + walletServer @WalletWebModeContext @WalletWebMode pm pc diffusion ntpStatus (convertHandler wwmc) walletWebModeContext :: WalletWebMode WalletWebModeContext walletWebModeContext = view (lensOf @WalletWebModeContextTag) diff --git a/wallet/src/Pos/Wallet/Web/State/State.hs b/wallet/src/Pos/Wallet/Web/State/State.hs index e6e330a4f3a..7b288ae666b 100644 --- a/wallet/src/Pos/Wallet/Web/State/State.hs +++ b/wallet/src/Pos/Wallet/Web/State/State.hs @@ -97,8 +97,8 @@ module Pos.Wallet.Web.State.State import Data.Acid (EventResult, EventState, QueryEvent, UpdateEvent) import qualified Data.Map as Map import Pos.Client.Txp.History (TxHistoryEntry) -import Pos.Core (Address, ChainDifficulty, HasProtocolConstants, - HeaderHash, SlotId, protocolConstants) +import Pos.Core (Address, ChainDifficulty, HeaderHash, + ProtocolConstants, SlotId) import Pos.Txp (TxId, Utxo, UtxoModifier) import Pos.Util.Servant (encodeCType) import Pos.Util.Util (HasLens', lensOf) @@ -481,14 +481,15 @@ removeOnlyCreatingPtx db walletId txId = updateDisk (A.RemoveOnlyCreatingPtx walletId txId) db ptxUpdateMeta - :: (MonadIO m, HasProtocolConstants) - => WalletDB + :: MonadIO m + => ProtocolConstants + -> WalletDB -> CId Wal -> TxId -> PtxMetaUpdate -> m () -ptxUpdateMeta db walletId txId metaUpdate = - updateDisk (A.PtxUpdateMeta protocolConstants walletId txId metaUpdate) db +ptxUpdateMeta pc db walletId txId metaUpdate = + updateDisk (A.PtxUpdateMeta pc walletId txId metaUpdate) db addOnlyNewPendingTx :: (MonadIO m) => WalletDB @@ -501,19 +502,18 @@ cancelApplyingPtxs :: (MonadIO m) -> m () cancelApplyingPtxs = updateDisk A.CancelApplyingPtxs -cancelSpecificApplyingPtx :: (MonadIO m) - => WalletDB -> TxId -> m () -cancelSpecificApplyingPtx db txid = updateDisk (A.CancelSpecificApplyingPtx txid) db +cancelSpecificApplyingPtx :: (MonadIO m) => WalletDB -> TxId -> m () +cancelSpecificApplyingPtx db txid = + updateDisk (A.CancelSpecificApplyingPtx txid) db -resetFailedPtxs :: (MonadIO m, HasProtocolConstants) - => WalletDB +resetFailedPtxs :: MonadIO m + => ProtocolConstants + -> WalletDB -> SlotId -> m () -resetFailedPtxs db slotId = updateDisk (A.ResetFailedPtxs protocolConstants slotId) db +resetFailedPtxs pc db slotId = updateDisk (A.ResetFailedPtxs pc slotId) db -flushWalletStorage :: (MonadIO m) - => WalletDB - -> m () +flushWalletStorage :: MonadIO m => WalletDB -> m () flushWalletStorage = updateDisk A.FlushWalletStorage applyModifierToWallet @@ -540,8 +540,9 @@ applyModifierToWallet db walId wAddrs custAddrs utxoMod db rollbackModifierFromWallet - :: (MonadIO m, HasProtocolConstants) - => WalletDB + :: MonadIO m + => ProtocolConstants + -> WalletDB -> CId Wal -> [S.WAddressMeta] -- ^ Addresses to remove -> [(S.CustomAddressType, [(Address, HeaderHash)])] -- ^ Custom addresses to remove @@ -552,11 +553,11 @@ rollbackModifierFromWallet -> [(TxId, PtxCondition, S.PtxMetaUpdate)] -- ^ Deleted PTX candidates -> WalletSyncState -- ^ New 'WalletSyncState' -> m () -rollbackModifierFromWallet db walId wAddrs custAddrs utxoMod +rollbackModifierFromWallet pc db walId wAddrs custAddrs utxoMod historyEntries ptxConditions syncState = updateDisk - ( A.RollbackModifierFromWallet2 protocolConstants + ( A.RollbackModifierFromWallet2 pc walId wAddrs custAddrs utxoMod historyEntries' ptxConditions syncState ) diff --git a/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs b/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs index 53c471955de..0cdf77eb483 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs @@ -21,8 +21,8 @@ import System.Wlog (HasLoggerName (modifyLoggerName), WithLogger) import Pos.Block.BListener (MonadBListener (..)) import Pos.Block.Types (Blund, undoTx) -import Pos.Core (HeaderHash, Timestamp, difficultyL, headerSlotL, - prevBlockL) +import Pos.Core (HeaderHash, ProtocolConstants, Timestamp, + difficultyL, headerSlotL, prevBlockL) import Pos.Core.Block (BlockHeader (..), blockHeader, getBlockHeader, mainBlockTxPayload) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) @@ -125,16 +125,18 @@ onApplyBlocksWebWallet blunds = setLogger . reportTimeouts "apply" $ do -- Perform this action under block lock. onRollbackBlocksWebWallet - :: forall ctx m . - ( AccountMode ctx m - , WS.WalletDbReader ctx m - , MonadDBRead m - , MonadSlots ctx m - , MonadReporting m - , CanLogInParallel m - ) - => NewestFirst NE Blund -> m SomeBatchOp -onRollbackBlocksWebWallet blunds = setLogger . reportTimeouts "rollback" $ do + :: forall ctx m + . ( AccountMode ctx m + , WS.WalletDbReader ctx m + , MonadDBRead m + , MonadSlots ctx m + , MonadReporting m + , CanLogInParallel m + ) + => ProtocolConstants + -> NewestFirst NE Blund + -> m SomeBatchOp +onRollbackBlocksWebWallet pc blunds = setLogger . reportTimeouts "rollback" $ do db <- WS.askWalletDB ws <- WS.getWalletSnapshot db let newestFirst = getNewestFirst blunds @@ -163,7 +165,7 @@ onRollbackBlocksWebWallet blunds = setLogger . reportTimeouts "rollback" $ do let rollbackBlockWith trackingOperation = do let dbUsed = WS.getCustomAddresses ws WS.UsedAddr mapModifier = trackingRollbackTxs (eskToWalletDecrCredentials encSK) dbUsed gbDiff blkHeaderTs txs - rollbackModifierFromWallet db trackingOperation wid newTip mapModifier + rollbackModifierFromWallet pc db trackingOperation wid newTip mapModifier logMsg "Rolled back" (getNewestFirst blunds) wid mapModifier rollbackBlockWith SyncWallet diff --git a/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs b/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs index 21e852552e5..6abf2c21d5d 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs @@ -57,9 +57,9 @@ import Pos.Block.Types (Blund, undoTx) import Pos.Client.Txp.History (TxHistoryEntry (..), txHistoryListToMap) import Pos.Core (Address, BlockCount (..), ChainDifficulty (..), - HasDifficulty (..), HasProtocolConstants, HeaderHash, - Timestamp (..), blkSecurityParam, genesisHash, headerHash, - headerSlotL, timestampToPosix) + HasDifficulty (..), HeaderHash, ProtocolConstants, + Timestamp (..), genesisHash, headerHash, headerSlotL, + pcEpochSlots, timestampToPosix) import Pos.Core.Block (BlockHeader (..), getBlockHeader, mainBlockTxPayload) import Pos.Core.Chrono (getNewestFirst) @@ -113,14 +113,16 @@ syncWallet credentials = submitSyncRequest (newSyncRequest credentials) -- | Asynchronously process a 'SyncRequest' by reading incoming -- requests from a 'SyncQueue', in an infinite loop. -processSyncRequest :: ( WalletDbReader ctx m - , BlockLockMode ctx m - , MonadSlotsData ctx m - ) => SyncQueue -> m () -processSyncRequest syncQueue = do +processSyncRequest + :: (WalletDbReader ctx m, BlockLockMode ctx m, MonadSlotsData ctx m) + => BlockCount + -> SyncQueue + -> m () +processSyncRequest k syncQueue = do newRequest <- atomically (readTQueue syncQueue) - syncWalletWithBlockchain newRequest >>= either processSyncError (const (logSuccess newRequest)) - processSyncRequest syncQueue + syncWalletWithBlockchain k newRequest + >>= either processSyncError (const (logSuccess newRequest)) + processSyncRequest k syncQueue -- | Yields a new 'CAccModifier' using the information retrieved from the mempool, if any. txMempoolToModifier :: WalletTrackingEnv ctx m @@ -194,9 +196,10 @@ syncWalletWithBlockchain , BlockLockMode ctx m , MonadSlotsData ctx m ) - => SyncRequest + => BlockCount + -> SyncRequest -> m SyncResult -syncWalletWithBlockchain syncRequest@SyncRequest{..} = setLogger $ do +syncWalletWithBlockchain k syncRequest@SyncRequest{..} = setLogger $ do ws <- WS.askWalletSnapshot let (_, walletId) = srCredentials let onError = pure . Left . SyncFailed walletId @@ -263,12 +266,12 @@ syncWalletWithBlockchain syncRequest@SyncRequest{..} = setLogger $ do -- guaranteed (by the protocol) to not be rolled-back and which can -- be considered stable and fully persisted into the blockchain. (syncResult, wNewTip) <- - if (currentBlockchainDepth > fromIntegral blkSecurityParam + fromIntegral wdiff) then do + if (currentBlockchainDepth > fromIntegral k + fromIntegral wdiff) then do -- Wallet tip is "far" from gState tip, -- rollback can't occur more then @blkSecurityParam@ blocks, -- so we can sync wallet and GState without the block lock -- to avoid blocking of blocks verification/application. - stableBlockHeader <- List.last . getNewestFirst <$> GS.loadHeadersByDepth (blkSecurityParam + 1) (headerHash gstateTipH) + stableBlockHeader <- List.last . getNewestFirst <$> GS.loadHeadersByDepth (k + 1) (headerHash gstateTipH) logInfo $ sformat ( "Wallet's tip is far from GState tip. Syncing with the last stable known header " %build% " (the tip of the blockchain - k blocks) without the block lock" @@ -625,27 +628,25 @@ applyModifierToWallet db trackingOperation wid newBlockHeaderTip CAccModifier{.. newSyncState rollbackModifierFromWallet - :: ( CanLog m - , HasLoggerName m - , MonadSlots ctx m - , HasProtocolConstants - ) - => WalletDB + :: (CanLog m, HasLoggerName m, MonadSlots ctx m) + => ProtocolConstants + -> WalletDB -> TrackingOperation -> CId Wal -> HeaderHash -> CAccModifier -> m () -rollbackModifierFromWallet db trackingOperation wid newTip CAccModifier{..} = do +rollbackModifierFromWallet pc db trackingOperation wid newTip CAccModifier{..} = do let newSyncState = case trackingOperation of SyncWallet -> SyncedWith newTip RestoreWallet rbd -> RestoringFrom rbd newTip logDebug $ sformat ("rollbackModifierFromWallet: new SyncState = " % shown) trackingOperation - curSlot <- getCurrentSlotInaccurate + curSlot <- getCurrentSlotInaccurate $ pcEpochSlots pc WS.rollbackModifierFromWallet + pc db wid (indexedDeletions camAddresses) diff --git a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs index 63ced68d85e..75eb626187e 100644 --- a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs @@ -29,13 +29,14 @@ import Pos.Wallet.Web.State (askWalletSnapshot, getWalletAddresses, wamAddress) import Pos.Wallet.Web.Util (decodeCTypeOrFail) import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Core.Dummy (dummyEpochSlots) import Test.Pos.Util.QuickCheck.Property (assertProperty, expectedOne) import Test.Pos.Wallet.Web.Mode (WalletProperty) import Test.Pos.Wallet.Web.Util (importSingleWallet, mostlyEmptyPassphrases) spec :: Spec -spec = withDefConfigurations $ \_ _ -> +spec = withDefConfigurations $ \_ -> describe "Fake address has maximal possible size" $ modifyMaxSuccess (const 10) $ do prop "getNewAddress" $ @@ -56,7 +57,7 @@ fakeAddressHasMaxSizeTest generator accSeed = do =<< newAccount (DeterminedSeed accSeed) passphrase (CAccountInit def wid) address <- generator accId passphrase - largeAddress <- lift getFakeChangeAddress + largeAddress <- lift $ getFakeChangeAddress dummyEpochSlots assertProperty (biSize largeAddress >= biSize address) @@ -66,7 +67,8 @@ fakeAddressHasMaxSizeTest generator accSeed = do -- Unfortunatelly, its randomness doesn't depend on QuickCheck seed, -- so another proper generator is helpful. changeAddressGenerator :: HasConfigurations => AddressGenerator -changeAddressGenerator accId passphrase = lift $ getNewAddress (accId, passphrase) +changeAddressGenerator accId passphrase = + lift $ getNewAddress dummyEpochSlots (accId, passphrase) -- | Generator which is directly used in endpoints. commonAddressGenerator :: AddressGenerator diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs index 99a1ff17e73..3c4f911c33a 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs @@ -20,7 +20,7 @@ import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Monadic (pick) spec :: Spec -spec = withDefConfigurations $ \_ _ -> +spec = withDefConfigurations $ \_ -> describe "restoreAddressFromWalletBackup" $ modifyMaxSuccess (const 10) $ do restoreWalletAddressFromBackupSpec diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs index 7910ef811a7..fa4f6a7ec88 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs @@ -19,7 +19,7 @@ import Test.Pos.Wallet.Web.Mode (WalletProperty) -- TODO remove HasCompileInfo when MonadWalletWebMode will be splitted. spec :: Spec -spec = withDefConfigurations $ \_ _ -> +spec = withDefConfigurations $ \_ -> describe "Pos.Wallet.Web.Methods" $ do prop emptyWalletOnStarts emptyWallet where diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs index 8f07e8e25d1..0d3e45b3820 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs @@ -46,12 +46,12 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, getAccountAddrsOrThrow) import Pos.Util.Servant (encodeCType) import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Core.Dummy (dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Property (assertProperty, expectedOne, maybeStopProperty, splitWord, stopProperty) import Test.Pos.Wallet.Web.Mode (WalletProperty, getSentTxs, submitTxTestMode, walletPropertySpec) - import Test.Pos.Wallet.Web.Util (deriveRandomAddress, expectedAddrBalance, importSomeWallets, mostlyEmptyPassphrases) @@ -62,7 +62,7 @@ deriving instance Eq CTx -- TODO remove HasCompileInfo when MonadWalletWebMode will be splitted. spec :: Spec spec = withCompileInfo $ - withDefConfigurations $ \_ _ -> + withDefConfigurations $ \_ -> describe "Wallet.Web.Methods.Payment" $ modifyMaxSuccess (const 10) $ do describe "newPaymentBatch" $ do describe "Submitting a payment when restoring" rejectPaymentIfRestoringSpec @@ -123,7 +123,7 @@ newPaymentFixture = do rejectPaymentIfRestoringSpec :: HasConfigurations => Spec rejectPaymentIfRestoringSpec = walletPropertySpec "should fail with 403" $ do PaymentFixture{..} <- newPaymentFixture - res <- lift $ try (newPaymentBatch dummyProtocolMagic submitTxTestMode pswd batch) + res <- lift $ try (newPaymentBatch dummyProtocolMagic dummyProtocolConstants submitTxTestMode pswd batch) liftIO $ shouldBe res (Left (err403 { errReasonPhrase = "Transaction creation is disabled when the wallet is restoring." })) -- | Test one single, successful payment. @@ -136,7 +136,7 @@ oneNewPaymentBatchSpec = walletPropertySpec oneNewPaymentBatchDesc $ do randomSyncTip <- liftIO $ generate arbitrary WS.setWalletSyncTip db walId randomSyncTip - void $ lift $ newPaymentBatch dummyProtocolMagic submitTxTestMode pswd batch + void $ lift $ newPaymentBatch dummyProtocolMagic dummyProtocolConstants submitTxTestMode pswd batch dstAddrs <- lift $ mapM decodeCTypeOrFail dstCAddrs txLinearPolicy <- lift $ (bvdTxFeePolicy <$> gsAdoptedBVData) <&> \case TxFeePolicyTxSizeLinear linear -> linear diff --git a/wallet/test/Test/Pos/Wallet/Web/Mode.hs b/wallet/test/Test/Pos/Wallet/Web/Mode.hs index f434c934f01..763f7ed5f1e 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Mode.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Mode.hs @@ -119,6 +119,7 @@ import Test.Pos.Block.Logic.Mode (BlockTestContext (..), getCurrentSlotBlockingTestDefault, getCurrentSlotInaccurateTestDefault, getCurrentSlotTestDefault, initBlockTestContext) +import Test.Pos.Core.Dummy (dummyEpochSlots) ---------------------------------------------------------------------------- -- Parameters @@ -210,7 +211,7 @@ initWalletTestContext WalletTestParams {..} callback = wtcLastKnownHeader <- STM.newTVarIO Nothing wtcSentTxs <- STM.newTVarIO mempty wtcSyncQueue <- STM.newTQueueIO - wtcSlottingStateVar <- mkSimpleSlottingStateVar + wtcSlottingStateVar <- mkSimpleSlottingStateVar dummyEpochSlots pure WalletTestContext {..} callback wtc @@ -294,11 +295,10 @@ instance HasLens DelegationVar WalletTestContext DelegationVar where instance HasLens SscMemTag WalletTestContext SscState where lensOf = wtcBlockTestContext_L . lensOf @SscMemTag -instance (HasConfiguration, MonadSlotsData ctx WalletTestMode) - => MonadSlots ctx WalletTestMode where - getCurrentSlot = getCurrentSlotTestDefault - getCurrentSlotBlocking = getCurrentSlotBlockingTestDefault - getCurrentSlotInaccurate = getCurrentSlotInaccurateTestDefault +instance MonadSlotsData ctx WalletTestMode => MonadSlots ctx WalletTestMode where + getCurrentSlot _ = getCurrentSlotTestDefault + getCurrentSlotBlocking _ = getCurrentSlotBlockingTestDefault + getCurrentSlotInaccurate _ = getCurrentSlotInaccurateTestDefault currentTimeSlotting = currentTimeSlottingTestDefault instance HasUserSecret WalletTestContext where @@ -380,8 +380,8 @@ instance HasLens (StateLockMetrics MemPoolModifyReason) WalletTestContext (State instance HasConfigurations => MonadAddresses WalletTestMode where type AddrData WalletTestMode = (AccountId, PassPhrase) - getNewAddress = getNewAddressWebWallet - getFakeChangeAddress = pure largestHDAddressBoot + getNewAddress _ = getNewAddressWebWallet + getFakeChangeAddress _ = pure largestHDAddressBoot instance MonadKeysRead WalletTestMode where getSecret = getSecretDefault diff --git a/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs index b40f421cbbd..7198c275531 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs @@ -20,7 +20,7 @@ import Test.QuickCheck.Monadic (pick) import Pos.Arbitrary.Wallet.Web.ClientTypes () import Pos.Block.Logic (rollbackBlocks) -import Pos.Core (Address, BlockCount (..), blkSecurityParam) +import Pos.Core (Address, BlockCount (..)) import Pos.Core.Chrono (nonEmptyOldestFirst, toNewestFirst) import Pos.Crypto (emptyPassphrase) import Pos.Launcher (HasConfigurations) @@ -41,13 +41,14 @@ import Pos.Wallet.Web.Tracking.Types (newSyncRequest) import Test.Pos.Block.Logic.Util (EnableTxPayload (..), InplaceDB (..)) import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Core.Dummy (dummyK, dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Property (assertProperty) import Test.Pos.Wallet.Web.Mode (walletPropertySpec) import Test.Pos.Wallet.Web.Util (importSomeWallets, wpGenBlocks) spec :: Spec -spec = withDefConfigurations $ \_ _ -> do +spec = withDefConfigurations $ \_ -> do describe "Pos.Wallet.Web.Tracking.BListener" $ modifyMaxSuccess (const 10) $ do describe "Two applications and rollbacks" twoApplyTwoRollbacksSpec xdescribe "Pos.Wallet.Web.Tracking.evalChange (pending, CSL-2473)" $ do @@ -61,12 +62,12 @@ spec = withDefConfigurations $ \_ _ -> do twoApplyTwoRollbacksSpec :: HasConfigurations => Spec twoApplyTwoRollbacksSpec = walletPropertySpec twoApplyTwoRollbacksDesc $ do - let k = fromIntegral blkSecurityParam :: Word64 + let k = fromIntegral dummyK :: Word64 -- During these tests we need to manually switch back to the old synchronous -- way of restoring. void $ importSomeWallets (pure emptyPassphrase) sks <- lift getSecretKeysPlain - lift $ forM_ sks $ \s -> syncWalletWithBlockchain (newSyncRequest (eskToWalletDecrCredentials s)) + lift $ forM_ sks $ \s -> syncWalletWithBlockchain dummyK (newSyncRequest (eskToWalletDecrCredentials s)) -- Testing starts here genesisWalletDB <- lift WS.askWalletSnapshot @@ -85,9 +86,9 @@ twoApplyTwoRollbacksSpec = walletPropertySpec twoApplyTwoRollbacksDesc $ do let toNE = fromMaybe (error "sequence of blocks are empty") . nonEmptyOldestFirst let to1Rollback = toNewestFirst $ toNE blunds2 let to2Rollback = toNewestFirst $ toNE blunds1 - lift $ rollbackBlocks dummyProtocolMagic to1Rollback + lift $ rollbackBlocks dummyProtocolMagic dummyProtocolConstants to1Rollback after1RollbackDB <- lift WS.askWalletSnapshot - lift $ rollbackBlocks dummyProtocolMagic to2Rollback + lift $ rollbackBlocks dummyProtocolMagic dummyProtocolConstants to2Rollback after2RollbackDB <- lift WS.askWalletSnapshot assertProperty (after1RollbackDB == after1ApplyDB) "wallet-db after first apply doesn't equal to wallet-db after first rollback" diff --git a/wallet/test/Test/Pos/Wallet/Web/Util.hs b/wallet/test/Test/Pos/Wallet/Web/Util.hs index e8ad0be90fd..ab44adf947e 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Util.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Util.hs @@ -64,6 +64,7 @@ import Pos.Infra.Util.JsonLog.Events (MemPoolModifyReason (ApplyBlock)) import Test.Pos.Block.Logic.Util (EnableTxPayload, InplaceDB, genBlockGenParams) +import Test.Pos.Core.Dummy (dummyProtocolConstants) import Test.Pos.Txp.Arbitrary () import Test.Pos.Util.QuickCheck.Property (assertProperty, maybeStopProperty) @@ -82,10 +83,10 @@ wpGenBlocks -> InplaceDB -> WalletProperty (OldestFirst [] Blund) wpGenBlocks pm blkCnt enTxPayload inplaceDB = do - params <- genBlockGenParams pm blkCnt enTxPayload inplaceDB + params <- genBlockGenParams blkCnt enTxPayload inplaceDB g <- pick $ MkGen $ \qc _ -> qc lift $ modifyStateLock HighPriority ApplyBlock $ \prevTip -> do -- FIXME is ApplyBlock the right one? - blunds <- OldestFirst <$> evalRandT (genBlocks pm params maybeToList) g + blunds <- OldestFirst <$> evalRandT (genBlocks pm dummyProtocolConstants params maybeToList) g case nonEmpty $ getOldestFirst blunds of Just nonEmptyBlunds -> do let tipBlockHeader = nonEmptyBlunds ^. _neLast . _1 . blockHeader