From 39c6899628aa1ef68d0b38ee94d54cd2d4eece70 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 | 17 +- auxx/Makefile | 13 ++ auxx/src/Command/BlockGen.hs | 22 ++- auxx/src/Command/Proc.hs | 39 ++-- auxx/src/Command/Rollback.hs | 9 +- auxx/src/Command/Tx.hs | 35 ++-- auxx/src/Mode.hs | 37 ++-- chain/bench/block-bench.hs | 12 +- chain/src/Pos/Chain/Block/BHelpers.hs | 18 +- chain/src/Pos/Chain/Block/JsonLog.hs | 10 +- chain/src/Pos/Chain/Block/Logic/Integrity.hs | 25 +-- chain/src/Pos/Chain/Block/Slog/Types.hs | 16 +- chain/src/Pos/Chain/Block/Types.hs | 24 +-- chain/src/Pos/Chain/Lrc/Fts.hs | 7 +- chain/src/Pos/Chain/Lrc/Genesis.hs | 13 +- chain/src/Pos/Chain/Ssc/Base.hs | 96 ++++------ chain/src/Pos/Chain/Ssc/Functions.hs | 40 ++-- chain/src/Pos/Chain/Ssc/Toss/Base.hs | 57 +++--- chain/src/Pos/Chain/Ssc/Toss/Class.hs | 8 +- chain/src/Pos/Chain/Ssc/Toss/Logic.hs | 78 ++++---- chain/src/Pos/Chain/Ssc/Toss/Pure.hs | 16 +- chain/src/Pos/Chain/Ssc/Toss/Types.hs | 12 +- chain/test/Test/Pos/Chain/Block/Arbitrary.hs | 82 +++----- .../Pos/Chain/Block/Arbitrary/Generate.hs | 15 +- chain/test/Test/Pos/Chain/Block/Bi.hs | 17 +- chain/test/Test/Pos/Chain/Block/BlockSpec.hs | 10 +- chain/test/Test/Pos/Chain/Block/CborSpec.hs | 5 +- chain/test/Test/Pos/Chain/Block/Gen.hs | 36 ++-- .../test/Test/Pos/Chain/Block/SafeCopySpec.hs | 4 +- chain/test/Test/Pos/Chain/Lrc/FtsSpec.hs | 34 ++-- chain/test/Test/Pos/Chain/Ssc/Arbitrary.hs | 24 ++- .../test/Test/Pos/Chain/Txp/Toil/UtxoSpec.hs | 94 +++++---- client/Makefile | 13 ++ client/cardano-sl-client.cabal | 1 + client/src/Pos/Client/Txp/Addresses.hs | 6 +- client/src/Pos/Client/Txp/History.hs | 37 ++-- client/src/Pos/Client/Txp/Network.hs | 17 +- client/src/Pos/Client/Txp/Util.hs | 108 ++++++----- client/test/Test/Pos/Client/Txp/Mode.hs | 8 +- client/test/Test/Pos/Client/Txp/UtilSpec.hs | 7 +- core/cardano-sl-core.cabal | 3 +- core/src/Pos/Core/Configuration.hs | 55 ++++-- core/src/Pos/Core/Configuration/Protocol.hs | 70 ------- core/src/Pos/Core/Genesis/Generate.hs | 21 +- core/src/Pos/Core/JsonLog/LogEvents.hs | 11 +- core/src/Pos/Core/ProtocolConstants.hs | 51 +++-- core/src/Pos/Core/Slotting/Class.hs | 13 +- core/src/Pos/Core/Slotting/EpochOrSlot.hs | 181 +++++++----------- core/src/Pos/Core/Slotting/LocalSlotIndex.hs | 96 ++++------ core/src/Pos/Core/Slotting/SlotId.hs | 66 +++---- core/src/Pos/Core/Slotting/Util.hs | 17 +- core/test/Test/Pos/Core/Arbitrary.hs | 36 ++-- core/test/Test/Pos/Core/Arbitrary/Unsafe.hs | 5 +- core/test/Test/Pos/Core/Bi.hs | 8 +- core/test/Test/Pos/Core/Dummy.hs | 38 +++- core/test/Test/Pos/Core/EnumEmpTest.hs | 108 ----------- core/test/Test/Pos/Core/ExampleHelpers.hs | 14 +- core/test/Test/Pos/Core/Gen.hs | 17 +- core/test/Test/Pos/Core/SlottingSpec.hs | 97 ++++++---- core/test/test.hs | 2 - db/Makefile | 13 ++ db/src/Pos/DB/Block/BListener.hs | 5 +- db/src/Pos/DB/Block/GState/BlockExtra.hs | 23 +-- db/src/Pos/DB/Block/Logic/Creation.hs | 154 ++++++++------- db/src/Pos/DB/Block/Logic/Header.hs | 20 +- db/src/Pos/DB/Block/Logic/Internal.hs | 41 ++-- db/src/Pos/DB/Block/Logic/Types.hs | 44 +++++ db/src/Pos/DB/Block/Logic/Util.hs | 46 ++--- db/src/Pos/DB/Block/Logic/VAR.hs | 73 ++++--- db/src/Pos/DB/Block/Lrc.hs | 37 ++-- db/src/Pos/DB/Block/Slog/Context.hs | 16 +- db/src/Pos/DB/Block/Slog/Logic.hs | 42 ++-- db/src/Pos/DB/Lrc/Leaders.hs | 36 ++-- db/src/Pos/DB/Ssc/Logic/Local.hs | 93 ++++----- db/src/Pos/DB/Ssc/Logic/VAR.hs | 55 +++--- db/src/Pos/DB/Ssc/State.hs | 16 +- db/src/Pos/DB/Ssc/State/Global.hs | 14 +- db/src/Pos/DB/Ssc/State/Local.hs | 31 +-- db/src/Pos/DB/Txp/Logic/Local.hs | 46 +++-- db/src/Pos/DB/Txp/MemState/Class.hs | 6 +- db/src/Pos/DB/Update/Context.hs | 15 +- db/src/Pos/DB/Update/GState.hs | 11 +- db/src/Pos/DB/Update/Logic/Global.hs | 37 ++-- db/src/Pos/DB/Update/Logic/Local.hs | 30 +-- db/src/Pos/DB/Update/MemState/Types.hs | 11 +- db/src/Pos/DB/Update/Poll/Logic/Apply.hs | 41 ++-- db/src/Pos/DB/Update/Poll/Logic/Base.hs | 18 +- db/src/Pos/DB/Update/Poll/Logic/Softfork.hs | 26 ++- db/test/Test/Pos/DB/Block/Arbitrary.hs | 3 +- db/test/Test/Pos/DB/Update/Arbitrary/Poll.hs | 13 +- explorer/Makefile | 13 ++ .../bench/Bench/Pos/Explorer/ServerBench.hs | 8 +- explorer/cardano-sl-explorer.cabal | 1 + explorer/src/Pos/Explorer/BListener.hs | 4 +- explorer/src/Pos/Explorer/DB.hs | 19 +- explorer/src/Pos/Explorer/ExplorerMode.hs | 22 +-- explorer/src/Pos/Explorer/Socket/App.hs | 33 ++-- explorer/src/Pos/Explorer/Socket/Methods.hs | 20 +- explorer/src/Pos/Explorer/TestUtil.hs | 64 +++---- explorer/src/Pos/Explorer/Txp/Global.hs | 7 +- explorer/src/Pos/Explorer/Txp/Local.hs | 44 +++-- explorer/src/Pos/Explorer/Web/ClientTypes.hs | 16 +- explorer/src/Pos/Explorer/Web/Server.hs | 63 +++--- explorer/src/Pos/Explorer/Web/Transform.hs | 21 +- explorer/src/explorer/Main.hs | 27 +-- .../test/Test/Pos/Explorer/Web/ServerSpec.hs | 9 +- generator/Makefile | 13 ++ generator/app/VerificationBench.hs | 44 ++--- .../bench/Bench/Pos/Criterion/Block/Logic.hs | 49 ++--- generator/src/Pos/Generator/Block/Logic.hs | 64 ++++--- generator/src/Pos/Generator/Block/Mode.hs | 39 ++-- generator/src/Pos/Generator/Block/Payload.hs | 25 +-- generator/src/Pos/Generator/BlockEvent.hs | 22 +-- generator/src/Pos/Generator/BlockEvent/DSL.hs | 8 +- generator/src/Test/Pos/Block/Logic/Event.hs | 13 +- generator/src/Test/Pos/Block/Logic/Mode.hs | 53 ++--- generator/src/Test/Pos/Block/Logic/Util.hs | 35 ++-- .../test/Test/Pos/Binary/CommunicationSpec.hs | 11 +- .../test/Test/Pos/Block/Logic/CreationSpec.hs | 36 ++-- .../test/Test/Pos/Block/Logic/VarSpec.hs | 53 +++-- .../test/Test/Pos/Generator/Block/LrcSpec.hs | 37 ++-- infra/Makefile | 13 ++ infra/src/Pos/Infra/DHT/Workers.hs | 18 +- infra/src/Pos/Infra/Recovery/Info.hs | 40 ++-- infra/src/Pos/Infra/Slotting/Impl/Simple.hs | 68 +++---- infra/src/Pos/Infra/Slotting/Impl/Util.hs | 22 +-- infra/src/Pos/Infra/Slotting/Util.hs | 40 ++-- .../Bench/Pos/Diffusion/BlockDownload.hs | 2 +- lib/src/Pos/DB/DB.hs | 25 ++- lib/src/Pos/GState/GState.hs | 9 +- lib/src/Pos/Launcher/Launcher.hs | 28 ++- lib/src/Pos/Launcher/Mode.hs | 4 +- lib/src/Pos/Launcher/Resource.hs | 31 +-- lib/src/Pos/Launcher/Runner.hs | 33 ++-- lib/src/Pos/Launcher/Scenario.hs | 10 +- lib/src/Pos/Listener/Txp.hs | 28 ++- lib/src/Pos/Listener/Update.hs | 16 +- lib/src/Pos/Logic/Full.hs | 45 +++-- lib/src/Pos/Network/Block/Logic.hs | 64 ++++--- lib/src/Pos/Network/Block/Retrieval.hs | 64 ++++--- lib/src/Pos/Recovery/Instance.hs | 56 ++++++ lib/src/Pos/WorkMode.hs | 6 +- lib/src/Pos/Worker.hs | 16 +- lib/src/Pos/Worker/Block.hs | 161 ++++++++-------- lib/src/Pos/Worker/Ssc.hs | 147 +++++++------- lib/src/Pos/Worker/Update.hs | 24 ++- lib/test/Test/Pos/Block/Arbitrary/Message.hs | 11 +- lib/test/Test/Pos/Cbor/CborSpec.hs | 3 +- lib/test/Test/Pos/Diffusion/BlockSpec.hs | 3 +- lib/test/Test/Pos/Genesis/CanonicalSpec.hs | 3 +- lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs | 27 +-- lib/test/Test/Pos/Ssc/Toss/PureSpec.hs | 2 +- lib/test/Test/Pos/Ssc/VssCertDataSpec.hs | 14 +- .../Test/Pos/Types/Identity/SafeCopySpec.hs | 3 +- lib/test/Test/Pos/Update/PollSpec.hs | 22 +-- node/Main.hs | 12 +- pkgs/default.nix | 5 + ssc/src/Pos/Ssc/Toss/Trans.hs | 106 ++++++++++ ssc/src/Pos/Ssc/Toss/Types.hs | 91 +++++++++ tools/src/dbgen/Main.hs | 16 +- tools/src/keygen/Main.hs | 23 +-- wallet-new/cardano-sl-wallet-new.cabal | 1 + wallet-new/server/Main.hs | 47 +++-- .../src/Cardano/Wallet/API/V0/Handlers.hs | 8 +- .../Cardano/Wallet/API/V1/LegacyHandlers.hs | 10 +- .../API/V1/LegacyHandlers/Transactions.hs | 31 ++- .../Wallet/API/V1/LegacyHandlers/Wallets.hs | 17 +- wallet-new/src/Cardano/Wallet/Kernel/Mode.hs | 16 +- .../Cardano/Wallet/Kernel/NodeStateAdaptor.hs | 22 +-- .../src/Cardano/Wallet/Kernel/Restore.hs | 8 +- wallet-new/src/Cardano/Wallet/LegacyServer.hs | 10 +- .../src/Cardano/Wallet/Server/Plugins.hs | 19 +- .../Wallet/WalletLayer/Kernel/Transactions.hs | 6 +- wallet-new/test/MarshallingSpec.hs | 15 +- wallet-new/test/WalletHandlersSpec.hs | 23 +-- wallet-new/test/unit/UTxO/Context.hs | 14 +- wallet-new/test/unit/UTxO/Interpreter.hs | 19 +- wallet-new/test/unit/UTxO/Translate.hs | 27 ++- wallet-new/test/unit/UTxO/Verify.hs | 33 ++-- wallet/Makefile | 2 +- wallet/src/Pos/Wallet/Redirect.hs | 14 +- wallet/src/Pos/Wallet/Web/Methods/Misc.hs | 12 +- wallet/src/Pos/Wallet/Web/Methods/Payment.hs | 41 ++-- wallet/src/Pos/Wallet/Web/Methods/Redeem.hs | 35 ++-- wallet/src/Pos/Wallet/Web/Methods/Txp.hs | 9 +- wallet/src/Pos/Wallet/Web/Mode.hs | 8 +- .../src/Pos/Wallet/Web/Pending/Functions.hs | 27 +-- .../src/Pos/Wallet/Web/Pending/Submission.hs | 17 +- wallet/src/Pos/Wallet/Web/Pending/Util.hs | 14 +- wallet/src/Pos/Wallet/Web/Pending/Worker.hs | 63 +++--- wallet/src/Pos/Wallet/Web/Server/Handlers.hs | 39 ++-- wallet/src/Pos/Wallet/Web/Server/Launcher.hs | 14 +- wallet/src/Pos/Wallet/Web/Server/Runner.hs | 15 +- wallet/src/Pos/Wallet/Web/State/State.hs | 38 ++-- .../src/Pos/Wallet/Web/Tracking/BListener.hs | 26 +-- wallet/src/Pos/Wallet/Web/Tracking/Sync.hs | 43 +++-- .../test/Test/Pos/Wallet/Web/AddressSpec.hs | 6 +- .../Pos/Wallet/Web/Methods/PaymentSpec.hs | 7 +- wallet/test/Test/Pos/Wallet/Web/Mode.hs | 17 +- .../Test/Pos/Wallet/Web/Tracking/SyncSpec.hs | 18 +- wallet/test/Test/Pos/Wallet/Web/Util.hs | 18 +- 201 files changed, 3219 insertions(+), 2821 deletions(-) create mode 100644 auxx/Makefile create mode 100644 client/Makefile delete mode 100644 core/src/Pos/Core/Configuration/Protocol.hs delete mode 100644 core/test/Test/Pos/Core/EnumEmpTest.hs create mode 100644 db/Makefile create mode 100644 db/src/Pos/DB/Block/Logic/Types.hs create mode 100644 explorer/Makefile create mode 100644 generator/Makefile create mode 100644 infra/Makefile create mode 100644 lib/src/Pos/Recovery/Instance.hs create mode 100644 ssc/src/Pos/Ssc/Toss/Trans.hs create mode 100644 ssc/src/Pos/Ssc/Toss/Types.hs diff --git a/auxx/Main.hs b/auxx/Main.hs index 40b0c6fbecf..e95d751baef 100644 --- a/auxx/Main.hs +++ b/auxx/Main.hs @@ -17,8 +17,8 @@ import Ntp.Client (NtpConfiguration) import Pos.Chain.Txp (TxpConfiguration) import qualified Pos.Client.CLI as CLI import Pos.Context (NodeContext (..)) -import Pos.Core as Core (Config (..), ConfigurationError, epochSlots) -import Pos.Crypto (ProtocolMagic) +import Pos.Core as Core (Config (..), ConfigurationError, + configBlkSecurityParam) import Pos.DB.DB (initNodeDBs) import Pos.DB.Txp (txpGlobalSettings) import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion) @@ -77,13 +77,13 @@ correctNodeParams AuxxOptions {..} np = do runNodeWithSinglePlugin :: (HasConfigurations, HasCompileInfo) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> NodeResources EmptyMempoolExt -> (Diffusion AuxxMode -> AuxxMode ()) -> Diffusion AuxxMode -> AuxxMode () -runNodeWithSinglePlugin pm txpConfig nr plugin = - runNode pm txpConfig nr [plugin] +runNodeWithSinglePlugin coreConfig txpConfig nr plugin = + runNode coreConfig txpConfig nr [plugin] action :: HasCompileInfo => AuxxOptions -> Either WithCommandAction Text -> IO () action opts@AuxxOptions {..} command = do @@ -97,7 +97,6 @@ action opts@AuxxOptions {..} command = do Light -> runWithoutNode pa _ -> withConfigurations Nothing conf (runWithConfig pa) - where runWithoutNode :: PrintAction IO -> IO () runWithoutNode printAction = printAction "Mode: light" >> rawExec Nothing Nothing Nothing opts Nothing command @@ -125,13 +124,13 @@ action opts@AuxxOptions {..} command = do sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig nodeParams) let pm = configProtocolMagic coreConfig - bracketNodeResources nodeParams sscParams (txpGlobalSettings pm txpConfig) (initNodeDBs pm epochSlots) $ \nr -> + bracketNodeResources (configBlkSecurityParam coreConfig) nodeParams sscParams (txpGlobalSettings pm txpConfig) (initNodeDBs coreConfig) $ \nr -> let NodeContext {..} = nrContext nr modifier = if aoStartMode == WithNode - then runNodeWithSinglePlugin pm txpConfig nr + then runNodeWithSinglePlugin coreConfig txpConfig nr else identity auxxModeAction = modifier (auxxPlugin coreConfig txpConfig opts command) - in runRealMode pm txpConfig nr $ \diffusion -> + in runRealMode coreConfig txpConfig nr $ \diffusion -> toRealMode (auxxModeAction (hoistDiffusion realModeToAuxx toRealMode diffusion)) cArgs@CLI.CommonNodeArgs {..} = aoCommonNodeArgs diff --git a/auxx/Makefile b/auxx/Makefile new file mode 100644 index 00000000000..7da04d8a2ef --- /dev/null +++ b/auxx/Makefile @@ -0,0 +1,13 @@ +help: ## Print documentation + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +ghcid: ## Run ghcid with the cardano-sl-auxx package + ghcid \ + --command "stack ghci cardano-sl-auxx --ghci-options=-fno-code" + +ghcid-test: ## Have ghcid run the test suite for the wallet-new-specs on successful recompile + ghcid \ + --command "stack ghci cardano-sl-auxx:lib cardano-sl-auxx:test:cardano-auxx-test --ghci-options=-fobject-code" \ + --test "Main.main" + +.PHONY: ghcid ghcid-test help diff --git a/auxx/src/Command/BlockGen.hs b/auxx/src/Command/BlockGen.hs index f0531ae575e..5aa6e806253 100644 --- a/auxx/src/Command/BlockGen.hs +++ b/auxx/src/Command/BlockGen.hs @@ -15,9 +15,9 @@ import System.Random (mkStdGen, randomIO) import Pos.AllSecrets (mkAllSecretsSimple) import Pos.Chain.Txp (TxpConfiguration) import Pos.Client.KeyStorage (getSecretKeysPlain) -import Pos.Core (genesisData) +import Pos.Core as Core (Config (..), genesisData) import Pos.Core.Genesis (gdBootStakeholders) -import Pos.Crypto (ProtocolMagic, encToSecret) +import Pos.Crypto (encToSecret) import Pos.DB.Txp (txpGlobalSettings) import Pos.Generator.Block (BlockGenParams (..), genBlocks, tgpTxCountRange) @@ -29,12 +29,12 @@ import Pos.Util.Wlog (logInfo) import Lang.Value (GenBlocksParams (..)) import Mode (MonadAuxxMode) - generateBlocks :: MonadAuxxMode m - => ProtocolMagic + => Core.Config -> TxpConfiguration - -> GenBlocksParams -> m () -generateBlocks pm txpConfig GenBlocksParams{..} = withStateLock HighPriority ApplyBlock $ \_ -> do + -> GenBlocksParams + -> m () +generateBlocks coreConfig txpConfig GenBlocksParams{..} = withStateLock HighPriority ApplyBlock $ \_ -> do seed <- liftIO $ maybe randomIO pure bgoSeed logInfo $ "Generating with seed " <> show seed @@ -45,13 +45,17 @@ generateBlocks pm txpConfig GenBlocksParams{..} = withStateLock HighPriority App { _bgpSecrets = allSecrets , _bgpGenStakeholders = gdBootStakeholders genesisData , _bgpBlockCount = fromIntegral bgoBlockN - -- tx generation is disalbed for now + -- tx generation is disabled for now , _bgpTxGenParams = def & tgpTxCountRange .~ (0,0) , _bgpInplaceDB = True , _bgpSkipNoKey = True - , _bgpTxpGlobalSettings = txpGlobalSettings pm txpConfig + , _bgpTxpGlobalSettings = txpGlobalSettings + (configProtocolMagic coreConfig) + txpConfig } - withCompileInfo $ evalRandT (genBlocks pm txpConfig bgenParams (const ())) (mkStdGen seed) + withCompileInfo $ evalRandT + (genBlocks coreConfig txpConfig 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 762430bc4f2..b2b1ae9b498 100644 --- a/auxx/src/Command/Proc.hs +++ b/auxx/src/Command/Proc.hs @@ -19,8 +19,8 @@ import Pos.Chain.Txp (TxpConfiguration) import Pos.Chain.Update (BlockVersionModifier (..)) import Pos.Client.KeyStorage (addSecretKey, getSecretKeysPlain) import Pos.Client.Txp.Balances (getBalance) -import Pos.Core as Core (AddrStakeDistribution (..), Address, - Config (..), StakeholderId, addressHash, +import Pos.Core as Core (AddrStakeDistribution (..), Config (..), + StakeholderId, addressHash, configEpochSlots, configGeneratedSecretsThrow, mkMultiKeyDistr, unsafeGetCoin) import Pos.Core.Common (AddrAttributes (..), AddrSpendingData (..), @@ -103,6 +103,7 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r }, let name = "addr" in + needsCoreConfig name >>= \coreConfig -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name @@ -114,7 +115,7 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r , cpExec = \(pk', mDistr) -> do pk <- toLeft pk' addr <- case mDistr of - Nothing -> makePubKeyAddressAuxx pk + Nothing -> makePubKeyAddressAuxx (configEpochSlots coreConfig) pk Just distr -> return $ makeAddress (PubKeyASD pk) (AddrAttributes Nothing distr) return $ ValueAddress addr @@ -124,6 +125,7 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r }, let name = "addr-hd" in + needsCoreConfig name >>= \coreConfig -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name @@ -134,7 +136,7 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r 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 (configEpochSlots coreConfig) sk return $ ValueAddress addrHD , cpHelp = "address of the HD wallet for the specified public key" }, @@ -191,13 +193,16 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r return . procConst "false" $ ValueBool False, let name = "balance" in + needsCoreConfig name >>= \coreConfig -> 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 $ configEpochSlots coreConfig) <=< + traverse (either return getPublicKeyFromIndex) $ addr' balance <- getBalance addr return $ ValueNumber (fromIntegral . unsafeGetCoin $ balance) , cpHelp = "check the amount of coins on the specified address" @@ -229,10 +234,7 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r return Tx.SendToAllGenesisParams{..} , cpExec = \stagp -> do secretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow coreConfig - Tx.sendToAllGenesis (configProtocolMagic coreConfig) - secretKeys - diffusion - stagp + Tx.sendToAllGenesis coreConfig secretKeys diffusion stagp return ValueUnit , cpHelp = "create and send transactions from all genesis addresses \ \ for seconds, in ms. is the \ @@ -263,7 +265,7 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r (,) <$> getArg tyInt "i" <*> getArgSome tyTxOut "out" , cpExec = \(i, outputs) -> do - Tx.send (configProtocolMagic coreConfig) diffusion i outputs + Tx.send coreConfig diffusion i outputs return ValueUnit , cpHelp = "send from #i to specified transaction outputs \ \ (use 'tx-out' to build them)" @@ -424,7 +426,7 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r bgoSeed <- getArgOpt tyInt "seed" return GenBlocksParams{..} , cpExec = \params -> do - generateBlocks (configProtocolMagic coreConfig) txpConfig params + generateBlocks coreConfig txpConfig params return ValueUnit , cpHelp = "generate blocks" }, @@ -479,26 +481,26 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r rpDumpPath <- getArg tyFilePath "dump-file" pure RollbackParams{..} , cpExec = \RollbackParams{..} -> do - Rollback.rollbackAndDump (configProtocolMagic coreConfig) - rpNum - rpDumpPath + Rollback.rollbackAndDump coreConfig rpNum rpDumpPath return ValueUnit , cpHelp = "" }, let name = "listaddr" in + needsCoreConfig name >>= \coreConfig -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name , cpArgumentPrepare = identity , cpArgumentConsumer = do pure () , cpExec = \() -> do + let epochSlots = configEpochSlots coreConfig 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"% @@ -507,7 +509,7 @@ createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = r i addr pk (addressHash pk) addrHD walletMB <- (^. usWallet) <$> (view userSecret >>= readTVarIO) whenJust walletMB $ \wallet -> do - addrHD <- deriveHDAddressAuxx (_wusRootKey wallet) + addrHD <- deriveHDAddressAuxx epochSlots (_wusRootKey wallet) printAction $ sformat (" Wallet address:\n"% " HD addr: "%build) @@ -558,9 +560,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 6391a1759b1..e693fa3e9a1 100644 --- a/auxx/src/Command/Rollback.hs +++ b/auxx/src/Command/Rollback.hs @@ -14,10 +14,9 @@ import Formatting (build, int, sformat, string, (%)) import Pos.Chain.Block (Blund, mainBlockTxPayload) import Pos.Chain.Txp (flattenTxPayload) -import Pos.Core (difficultyL, epochIndexL) +import Pos.Core as Core (Config, difficultyL, epochIndexL) import Pos.Core.Chrono (NewestFirst, _NewestFirst) import Pos.Core.Txp (TxAux) -import Pos.Crypto (ProtocolMagic) import Pos.DB.Block (BypassSecurityCheck (..), ShouldCallBListener (..), rollbackBlocksUnsafe) import qualified Pos.DB.Block as DB @@ -32,11 +31,11 @@ import Mode (MonadAuxxMode) -- from it to the given file. rollbackAndDump :: MonadAuxxMode m - => ProtocolMagic + => Core.Config -> Word -> FilePath -> m () -rollbackAndDump pm numToRollback outFile = withStateLock HighPriority ApplyBlockWithRollback $ \_ -> do +rollbackAndDump coreConfig numToRollback outFile = withStateLock HighPriority ApplyBlockWithRollback $ \_ -> do printTipDifficulty blundsMaybeEmpty <- modifyBlunds <$> DB.loadBlundsFromTipByDepth (fromIntegral numToRollback) @@ -53,7 +52,7 @@ rollbackAndDump pm numToRollback outFile = withStateLock HighPriority ApplyBlock liftIO $ BSL.writeFile outFile (encode allTxs) logInfo $ sformat ("Dumped "%int%" transactions to "%string) (length allTxs) (outFile) - rollbackBlocksUnsafe pm (BypassSecurityCheck True) (ShouldCallBListener True) blunds + rollbackBlocksUnsafe coreConfig (BypassSecurityCheck True) (ShouldCallBListener True) blunds logInfo $ sformat ("Rolled back "%int%" blocks") (length blunds) printTipDifficulty where diff --git a/auxx/src/Command/Tx.hs b/auxx/src/Command/Tx.hs index 5f01799012d..b602cde4d84 100644 --- a/auxx/src/Command/Tx.hs +++ b/auxx/src/Command/Tx.hs @@ -38,17 +38,18 @@ import Pos.Client.KeyStorage (getSecretKeysPlain) import Pos.Client.Txp.Balances (getOwnUtxoForPk) import Pos.Client.Txp.Network (prepareMTx, submitTxRaw) import Pos.Client.Txp.Util (createTx) -import Pos.Core (IsBootstrapEraAddr (..), Timestamp (..), - deriveFirstHDAddress, makePubKeyAddress, mkCoin) +import Pos.Core as Core (Config, IsBootstrapEraAddr (..), + Timestamp (..), configEpochSlots, deriveFirstHDAddress, + makePubKeyAddress, mkCoin) import Pos.Core.Conc (concurrently, currentTime, delay, forConcurrently, modifySharedAtomic, newSharedAtomic) import Pos.Core.Configuration (genesisBlockVersionData) import Pos.Core.Txp (TxAux (..), TxIn (TxInUtxo), TxOut (..), TxOutAux (..), txaF) import Pos.Core.Update (BlockVersionData (..)) -import Pos.Crypto (EncryptedSecretKey, ProtocolMagic, SecretKey, - emptyPassphrase, encToPublic, fakeSigner, hash, - safeToPublic, toPublic, withSafeSigners) +import Pos.Crypto (EncryptedSecretKey, SecretKey, emptyPassphrase, + encToPublic, fakeSigner, hash, safeToPublic, toPublic, + withSafeSigners) import Pos.Infra.Diffusion.Types (Diffusion (..)) import Pos.Util.UserSecret (usWallet, userSecret, wusRootKey) import Pos.Util.Util (maybeThrow) @@ -84,13 +85,14 @@ addTxSubmit = pure (TxCount (submitted + 1) sending, ())) sendToAllGenesis - :: forall m. MonadAuxxMode m - => ProtocolMagic + :: forall m + . MonadAuxxMode m + => Core.Config -> [SecretKey] -> Diffusion m -> SendToAllGenesisParams -> m () -sendToAllGenesis pm keysToSend diffusion (SendToAllGenesisParams genesisTxsPerThread txsPerThread conc delay_ tpsSentFile) = do +sendToAllGenesis coreConfig keysToSend diffusion (SendToAllGenesisParams genesisTxsPerThread txsPerThread conc delay_ tpsSentFile) = do let genesisSlotDuration = fromIntegral (toMicroseconds $ bvdSlotDuration genesisBlockVersionData) `div` 1000000 :: Int tpsMVar <- newSharedAtomic $ TxCount 0 conc startTime <- show . toInteger . getTimestamp . Timestamp <$> currentTime @@ -114,14 +116,16 @@ sendToAllGenesis pm keysToSend diffusion (SendToAllGenesisParams genesisTxsPerTh let signer = fakeSigner secretKey publicKey = toPublic secretKey -- construct transaction output - outAddr <- makePubKeyAddressAuxx publicKey + outAddr <- makePubKeyAddressAuxx + (configEpochSlots coreConfig) + 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 coreConfig 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 +147,7 @@ sendToAllGenesis pm keysToSend diffusion (SendToAllGenesisParams genesisTxsPerTh 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 coreConfig 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,13 +222,14 @@ newtype AuxxException = AuxxException Text instance Exception AuxxException send - :: forall m. MonadAuxxMode m - => ProtocolMagic + :: forall m + . MonadAuxxMode m + => Core.Config -> Diffusion m -> Int -> NonEmpty TxOut -> m () -send pm diffusion idx outputs = do +send coreConfig diffusion idx outputs = do skey <- takeSecret let curPk = encToPublic skey let plainAddresses = map (flip makePubKeyAddress curPk . IsBootstrapEraAddr) [False, True] @@ -237,7 +242,7 @@ send pm diffusion idx outputs = 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,_) <- lift $ prepareMTx coreConfig 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) diff --git a/auxx/src/Mode.hs b/auxx/src/Mode.hs index ad3c5626d54..2141be6cc8a 100644 --- a/auxx/src/Mode.hs +++ b/auxx/src/Mode.hs @@ -40,7 +40,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.Core.JsonLog (CanJsonLog (..)) @@ -163,12 +163,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 @@ -217,8 +215,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 @@ -236,7 +234,7 @@ type instance MempoolExt AuxxMode = EmptyMempoolExt instance HasConfiguration => MonadTxpLocal AuxxMode where txpNormalize pm = withReaderT acRealModeContext . txNormalize pm - txpProcessTx pm txpConfig = withReaderT acRealModeContext . txProcessTransaction pm txpConfig + txpProcessTx coreConfig txpConfig = withReaderT acRealModeContext . txProcessTransaction coreConfig txpConfig instance HasConfigurations => MonadTxpLocal (BlockGenMode EmptyMempoolExt AuxxMode) where @@ -246,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/chain/bench/block-bench.hs b/chain/bench/block-bench.hs index 1a64b7351ed..e634672f0dc 100644 --- a/chain/bench/block-bench.hs +++ b/chain/bench/block-bench.hs @@ -30,13 +30,6 @@ import Test.Pos.Chain.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 @@ -94,13 +87,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/chain/src/Pos/Chain/Block/BHelpers.hs b/chain/src/Pos/Chain/Block/BHelpers.hs index a4620d23a7d..f6d550c7b84 100644 --- a/chain/src/Pos/Chain/Block/BHelpers.hs +++ b/chain/src/Pos/Chain/Block/BHelpers.hs @@ -31,7 +31,7 @@ import Pos.Chain.Block.Union (Block, BlockHeader (..), MainConsensusData (..), MainToSign (..), mainBlockEBDataProof) import Pos.Chain.Ssc (verifySscPayload) -import Pos.Core.Configuration (HasProtocolConstants) +import Pos.Core as Core (Config (..)) import Pos.Core.Delegation (LightDlgIndices (..), checkDlgPayload) import Pos.Core.Slotting (SlotId (..)) import Pos.Core.Ssc (checkSscPayload) @@ -53,13 +53,11 @@ verifyBlockHeader pm (BlockHeaderMain bhm) = verifyMainBlockHeader pm bhm -- | Verify a Block in isolation. verifyBlock - :: ( MonadError Text m - , HasProtocolConstants - ) - => ProtocolMagic + :: MonadError Text m + => Core.Config -> Block -> m () -verifyBlock pm = either verifyGenesisBlock (verifyMainBlock pm) +verifyBlock coreConfig = either verifyGenesisBlock (verifyMainBlock coreConfig) -- | To verify a genesis block we only have to check the body proof. verifyGenesisBlock @@ -72,12 +70,12 @@ verifyGenesisBlock UnsafeGenericBlock {..} = verifyMainBlock :: ( MonadError Text m , Bi MainProof - , HasProtocolConstants ) - => ProtocolMagic + => Core.Config -> GenericBlock MainBlockchain -> m () -verifyMainBlock pm block@UnsafeGenericBlock {..} = do +verifyMainBlock coreConfig block@UnsafeGenericBlock {..} = do + let pm = configProtocolMagic coreConfig verifyMainBlockHeader pm _gbHeader verifyMainBody pm _gbBody -- No need to verify the main extra body data. It's an 'Attributes ()' @@ -93,7 +91,7 @@ verifyMainBlock pm block@UnsafeGenericBlock {..} = do -- be done in 'verifyMainBody'. either (throwError . pretty) pure $ verifySscPayload - pm + coreConfig (Right (Some _gbHeader)) (_mbSscPayload _gbBody) diff --git a/chain/src/Pos/Chain/Block/JsonLog.hs b/chain/src/Pos/Chain/Block/JsonLog.hs index 1f6462fccd3..e7afef69269 100644 --- a/chain/src/Pos/Chain/Block/JsonLog.hs +++ b/chain/src/Pos/Chain/Block/JsonLog.hs @@ -13,15 +13,15 @@ import Pos.Chain.Block.Blockchain (gbHeader, gbhPrevBlock) import Pos.Chain.Block.Genesis (genBlockEpoch) import Pos.Chain.Block.Union (Block, HeaderHash, headerHash, headerHashF, mainBlockSlot, mainBlockTxPayload) -import Pos.Core (HasConfiguration, SlotId (..), getEpochIndex, - getSlotIndex, mkLocalSlotIndex) +import Pos.Core (SlotCount, SlotId (..), getEpochIndex, getSlotIndex, + mkLocalSlotIndex) import Pos.Core.JsonLog.LogEvents (JLBlock (..), JLEvent (..)) import Pos.Core.Txp (txpTxs) import Pos.Crypto (hash, hashHexF) -- | Return event of created block. -jlCreatedBlock :: HasConfiguration => Block -> JLEvent -jlCreatedBlock block = JLCreatedBlock $ JLBlock {..} +jlCreatedBlock :: SlotCount -> Block -> JLEvent +jlCreatedBlock epochSlots block = JLCreatedBlock $ JLBlock {..} where jlHash = showHeaderHash $ headerHash block jlPrevBlock = showHeaderHash $ case block of @@ -33,7 +33,7 @@ jlCreatedBlock block = JLCreatedBlock $ JLBlock {..} Right mB -> map fromTx . toList $ mB ^. mainBlockTxPayload . txpTxs 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/chain/src/Pos/Chain/Block/Logic/Integrity.hs b/chain/src/Pos/Chain/Block/Logic/Integrity.hs index 21fd085c92f..a472fbbe54d 100644 --- a/chain/src/Pos/Chain/Block/Logic/Integrity.hs +++ b/chain/src/Pos/Chain/Block/Logic/Integrity.hs @@ -34,9 +34,9 @@ import Pos.Chain.Block.Union (Block, BlockHeader (..), HasHeaderHash (..), HeaderHash, blockHeaderProtocolMagic, getBlockHeader, headerSlotL, mainHeaderLeaderKey, mebAttributes, mehAttributes, prevBlockL) -import Pos.Core (ChainDifficulty, EpochOrSlot, HasDifficulty (..), - HasEpochIndex (..), HasEpochOrSlot (..), - HasProtocolConstants, SlotId (..), SlotLeaders, +import Pos.Core as Core (ChainDifficulty, Config (..), EpochOrSlot, + HasDifficulty (..), HasEpochIndex (..), + HasEpochOrSlot (..), SlotId (..), SlotLeaders, addressHash, getSlotIndex) import Pos.Core.Attributes (areAttributesKnown) import Pos.Core.Chrono (NewestFirst (..), OldestFirst) @@ -266,14 +266,16 @@ instance NFData VerifyBlockParams -- 2. The size of each block does not exceed `bvdMaxBlockSize`. -- 3. (Optional) No block has any unknown attributes. verifyBlock - :: HasProtocolConstants - => ProtocolMagic + :: Core.Config -> VerifyBlockParams -> Block -> VerificationRes -verifyBlock pm VerifyBlockParams {..} blk = mconcat - [ verifyFromEither "internal block consistency" (BHelpers.verifyBlock pm blk) - , verifyHeader pm vbpVerifyHeader (getBlockHeader blk) +verifyBlock coreConfig VerifyBlockParams {..} blk = mconcat + [ verifyFromEither "internal block consistency" + (BHelpers.verifyBlock coreConfig blk) + , verifyHeader (configProtocolMagic coreConfig) + vbpVerifyHeader + (getBlockHeader blk) , checkSize vbpMaxSize , bool mempty (verifyNoUnknown blk) vbpVerifyNoUnknown ] @@ -315,15 +317,14 @@ type VerifyBlocksIter = (SlotLeaders, Maybe BlockHeader, VerificationRes) -- laziness of 'VerificationRes' which is good because laziness for this data -- type is crucial. verifyBlocks - :: HasProtocolConstants - => ProtocolMagic + :: Core.Config -> Maybe SlotId -> Bool -> BlockVersionData -> SlotLeaders -> OldestFirst [] Block -> VerificationRes -verifyBlocks pm curSlotId verifyNoUnknown bvd initLeaders = view _3 . foldl' step start +verifyBlocks coreConfig curSlotId verifyNoUnknown bvd initLeaders = view _3 . foldl' step start where start :: VerifyBlocksIter -- Note that here we never know previous header before this @@ -352,4 +353,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 coreConfig vbp blk) diff --git a/chain/src/Pos/Chain/Block/Slog/Types.hs b/chain/src/Pos/Chain/Block/Slog/Types.hs index b9cd8eab4bf..1cc538dadef 100644 --- a/chain/src/Pos/Chain/Block/Slog/Types.hs +++ b/chain/src/Pos/Chain/Block/Slog/Types.hs @@ -11,19 +11,18 @@ module Pos.Chain.Block.Slog.Types , HasSlogContext (..) , SlogUndo (..) + , buildSlogUndo ) where import Universum import Control.Lens (makeClassy) -import Formatting (bprint) -import qualified Formatting.Buildable +import Formatting (Format, bprint, later) import System.Metrics.Label (Label) import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) import Pos.Core (ChainDifficulty, EpochIndex, FlatSlotId, - HasProtocolConstants, LocalSlotIndex, slotIdF, - unflattenSlotId) + LocalSlotIndex, SlotCount, slotIdF, unflattenSlotId) import Pos.Core.Chrono (OldestFirst (..)) import Pos.Core.Reporting (MetricMonitorState) @@ -92,10 +91,10 @@ 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 -- TH derived instances at the end of the file. @@ -103,4 +102,3 @@ deriveSimpleBi ''SlogUndo [ Cons 'SlogUndo [ Field [| getSlogUndo :: Maybe FlatSlotId |] ]] - diff --git a/chain/src/Pos/Chain/Block/Types.hs b/chain/src/Pos/Chain/Block/Types.hs index 555c5b6753a..3e353b04e6e 100644 --- a/chain/src/Pos/Chain/Block/Types.hs +++ b/chain/src/Pos/Chain/Block/Types.hs @@ -5,6 +5,7 @@ module Pos.Chain.Block.Types ( SlogUndo (..) , Undo (..) + , buildUndo , Blund , LastKnownHeader @@ -14,16 +15,15 @@ module Pos.Chain.Block.Types import Universum -import Formatting (bprint, build, (%)) -import qualified Formatting.Buildable +import Formatting (Format, bprint, build, later, (%)) import Serokell.Util.Text (listJson) import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) -import Pos.Chain.Block.Slog.Types (SlogUndo (..)) +import Pos.Chain.Block.Slog.Types (SlogUndo (..), buildSlogUndo) import Pos.Chain.Block.Union (Block, BlockHeader, HasHeaderHash (..)) import Pos.Chain.Delegation (DlgUndo) import Pos.Chain.Update (USUndo) -import Pos.Core (HasConfiguration, HasDifficulty (..)) +import Pos.Core (HasDifficulty (..), SlotCount) import Pos.Core.Txp (TxpUndo) import Pos.Util.Util (HasLens (..)) @@ -40,14 +40,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/chain/src/Pos/Chain/Lrc/Fts.hs b/chain/src/Pos/Chain/Lrc/Fts.hs index a01ab352f36..b054d89f413 100644 --- a/chain/src/Pos/Chain/Lrc/Fts.hs +++ b/chain/src/Pos/Chain/Lrc/Fts.hs @@ -1,4 +1,3 @@ - -- | Base part of /follow-the-satoshi/ procedure. module Pos.Chain.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/chain/src/Pos/Chain/Lrc/Genesis.hs b/chain/src/Pos/Chain/Lrc/Genesis.hs index 0798351da0c..e9853e333dd 100644 --- a/chain/src/Pos/Chain/Lrc/Genesis.hs +++ b/chain/src/Pos/Chain/Lrc/Genesis.hs @@ -17,18 +17,15 @@ import Pos.Core.Genesis (GenesisData (..)) -- | 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 = -- NB: here we rely on the ordering produced by HM.toList; if it changes, -- `genesisLeaders` might start producing different results. Be careful with diff --git a/chain/src/Pos/Chain/Ssc/Base.hs b/chain/src/Pos/Chain/Ssc/Base.hs index dc8e4edfc61..7f67682484a 100644 --- a/chain/src/Pos/Chain/Ssc/Base.hs +++ b/chain/src/Pos/Chain/Ssc/Base.hs @@ -6,17 +6,11 @@ module Pos.Chain.Ssc.Base ( -- * Helpers - isCommitmentIdExplicit - , isCommitmentId - , isCommitmentIdxExplicit + isCommitmentId , isCommitmentIdx - , isOpeningIdExplicit , isOpeningId - , isOpeningIdxExplicit , isOpeningIdx - , isSharesIdExplicit , isSharesId - , isSharesIdxExplicit , isSharesIdx , mkSignedCommitment , secretToSharedSeed @@ -49,14 +43,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, - pcEpochSlots, unsafeMkLocalSlotIndexExplicit) -import Pos.Core.Configuration (HasProtocolConstants, - protocolConstants, vssMaxTTL, vssMinTTL) +import Pos.Core (BlockCount, EpochIndex (..), LocalSlotIndex, + SharedSeed (..), SlotCount, SlotId (..), StakeholderId, + addressHash, unsafeMkLocalSlotIndex) import Pos.Core.Limits (stripHashMap) import Pos.Core.ProtocolConstants (ProtocolConstants (..), - pcSlotSecurityParam) + kEpochSlots, kSlotSecurityParam, vssMaxTTL, vssMinTTL) import Pos.Core.Ssc (Commitment (..), CommitmentsMap (getCommitmentsMap), Opening (..), SignedCommitment, SscPayload (..), @@ -84,50 +76,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 (pcEpochSlots 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 @@ -226,10 +204,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 @@ -267,9 +245,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/chain/src/Pos/Chain/Ssc/Functions.hs b/chain/src/Pos/Chain/Ssc/Functions.hs index 2f225ef9cbe..d7067dc55de 100644 --- a/chain/src/Pos/Chain/Ssc/Functions.hs +++ b/chain/src/Pos/Chain/Ssc/Functions.hs @@ -28,13 +28,12 @@ import Pos.Chain.Ssc.Error (SscVerifyError (..)) import Pos.Chain.Ssc.Toss.Base (verifyEntriesGuardM) import Pos.Chain.Ssc.Types (SscGlobalState (..)) import qualified Pos.Chain.Ssc.VssCertData as VCD -import Pos.Core (EpochIndex (..), HasGenesisData, - HasProtocolConstants, SlotId (..), StakeholderId, - genesisVssCerts) +import Pos.Core as Core (BlockCount, Config (..), EpochIndex (..), + HasGenesisData, SlotId (..), StakeholderId, + genesisVssCerts, pcBlkSecurityParam) import Pos.Core.Slotting (crucialSlot) import Pos.Core.Ssc (CommitmentsMap (..), SscPayload (..), VssCertificatesMap) -import Pos.Crypto (ProtocolMagic) import Pos.Util.Some (Some) ---------------------------------------------------------------------------- @@ -70,9 +69,9 @@ 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 + => Core.Config -> Either EpochIndex (Some IsMainHeader) -> SscPayload -> m () +verifySscPayload coreConfig eoh payload = case payload of CommitmentsPayload comms certs -> do whenHeader eoh isComm commChecks comms @@ -91,11 +90,13 @@ 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 + pc = configProtocolConstants coreConfig + 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 @@ -112,7 +113,9 @@ verifySscPayload pm eoh payload = case payload of -- -- #verifySignedCommitment commChecks commitments = do - let checkComm = isVerSuccess . verifySignedCommitment pm epochId + let checkComm = isVerSuccess . verifySignedCommitment + (configProtocolMagic coreConfig) + epochId verifyEntriesGuardM fst snd CommitmentInvalid (pure . checkComm) (HM.toList . getCommitmentsMap $ commitments) @@ -125,15 +128,20 @@ 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 + VCD.certs $ VCD.setLastKnownSlot (crucialSlot k epoch) certs diff --git a/chain/src/Pos/Chain/Ssc/Toss/Base.hs b/chain/src/Pos/Chain/Ssc/Toss/Base.hs index 40e1a63ec9f..1c9376f1dbd 100644 --- a/chain/src/Pos/Chain/Ssc/Toss/Base.hs +++ b/chain/src/Pos/Chain/Ssc/Toss/Base.hs @@ -52,8 +52,9 @@ import Pos.Chain.Ssc.Base (verifyOpening, vssThreshold) import Pos.Chain.Ssc.Error (SscVerifyError (..)) import Pos.Chain.Ssc.Toss.Class (MonadToss (..), MonadTossEnv (..), MonadTossRead (..)) -import Pos.Core (CoinPortion, EpochIndex, StakeholderId, addressHash, - coinPortionDenominator, getCoinPortion, unsafeGetCoin) +import Pos.Core (BlockCount, CoinPortion, EpochIndex, StakeholderId, + addressHash, coinPortionDenominator, getCoinPortion, + unsafeGetCoin) import Pos.Core.Ssc (Commitment (..), CommitmentsMap (getCommitmentsMap), InnerSharesMap, Opening (..), OpeningsMap, SharesDistribution, SharesMap, @@ -95,11 +96,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 @@ -116,9 +119,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) @@ -397,18 +403,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) @@ -444,14 +450,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 @@ -459,7 +466,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 @@ -488,17 +495,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/chain/src/Pos/Chain/Ssc/Toss/Class.hs b/chain/src/Pos/Chain/Ssc/Toss/Class.hs index 55f8832fe8f..e4c36d7e786 100644 --- a/chain/src/Pos/Chain/Ssc/Toss/Class.hs +++ b/chain/src/Pos/Chain/Ssc/Toss/Class.hs @@ -14,7 +14,7 @@ import Control.Monad.Except (ExceptT) import Control.Monad.Trans (MonadTrans) import Pos.Chain.Lrc (RichmenStakes) -import Pos.Core (EpochIndex, EpochOrSlot, StakeholderId) +import Pos.Core (BlockCount, EpochIndex, EpochOrSlot, StakeholderId) import Pos.Core.Ssc (CommitmentsMap, InnerSharesMap, Opening, OpeningsMap, SharesMap, SignedCommitment, VssCertificate, VssCertificatesMap) @@ -42,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) => @@ -62,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/chain/src/Pos/Chain/Ssc/Toss/Logic.hs b/chain/src/Pos/Chain/Ssc/Toss/Logic.hs index a7c1aa20ef0..2a8c13a2ab7 100644 --- a/chain/src/Pos/Chain/Ssc/Toss/Logic.hs +++ b/chain/src/Pos/Chain/Ssc/Toss/Logic.hs @@ -23,17 +23,17 @@ import Pos.Chain.Ssc.Functions (verifySscPayload) import Pos.Chain.Ssc.Toss.Base (checkPayload) import Pos.Chain.Ssc.Toss.Class (MonadToss (..), MonadTossEnv (..)) import Pos.Chain.Ssc.Toss.Types (TossModifier (..)) -import Pos.Core (EpochIndex, EpochOrSlot (..), HasProtocolConstants, +import Pos.Core as Core (Config (..), EpochIndex, EpochOrSlot (..), LocalSlotIndex, SlotCount, SlotId (siSlot), StakeholderId, - epochIndexL, epochOrSlot, getEpochOrSlot, mkCoin, - slotSecurityParam) + configBlkSecurityParam, configSlotSecurityParam, + epochIndexL, epochOrSlot, epochOrSlotPred, + epochOrSlotToEnum, getEpochOrSlot, getSlotIndex, mkCoin) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Ssc (CommitmentsMap (..), InnerSharesMap, Opening, SignedCommitment, SscPayload (..), VssCertificate, checkSscPayload, getCommitmentsMap, getVssCertificatesMap, mkCommitmentsMapUnsafe, mkVssCertificatesMapSingleton, spVss) -import Pos.Crypto (ProtocolMagic) import Pos.Util.AssertMode (inAssertMode) import Pos.Util.Some (Some) import Pos.Util.Util (sortWithMDesc) @@ -43,31 +43,32 @@ import Pos.Util.Wlog (logError) -- MonadToss. If data is valid it is also applied. Otherwise -- SscVerifyError is thrown using 'MonadError' type class. verifyAndApplySscPayload - :: ( HasProtocolConstants + :: ( MonadToss m + , MonadTossEnv m , MonadError SscVerifyError m , MonadRandom m - , MonadToss m - , MonadTossEnv m ) - => ProtocolMagic + => Core.Config -> Either EpochIndex (Some IsMainHeader) -> SscPayload -> m () -verifyAndApplySscPayload pm eoh payload = do +verifyAndApplySscPayload coreConfig eoh payload = do -- Check the payload for internal consistency. - either (throwError . SscInvalidPayload) pure (checkSscPayload pm payload) + either (throwError . SscInvalidPayload) + pure + (checkSscPayload (configProtocolMagic coreConfig) payload) -- We can't trust payload from mempool, so we must call -- @verifySscPayload@. - whenLeft eoh $ const $ verifySscPayload pm eoh payload + whenLeft eoh $ const $ verifySscPayload coreConfig eoh payload -- We perform @verifySscPayload@ for block when we construct it -- (in the 'recreateGenericBlock'). So this check is just in case. -- NOTE: in block verification `verifySscPayload` on `MainBlock` is run -- by `Pos.Block.BHelper.verifyMainBlock` inAssertMode $ - whenRight eoh $ const $ verifySscPayload pm eoh payload + whenRight eoh $ const $ verifySscPayload coreConfig eoh payload let blockCerts = spVss payload let curEpoch = either identity (^. epochIndexL) eoh - checkPayload curEpoch payload + checkPayload (configBlkSecurityParam coreConfig) curEpoch payload -- Apply case eoh of @@ -79,8 +80,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 + slotSecurityParam = configSlotSecurityParam coreConfig when (slotSecurityParam <= slot && slot < 2 * slotSecurityParam) $ resetShares mapM_ putCertificate blockCerts @@ -107,18 +109,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 _) = @@ -129,11 +133,14 @@ 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) + => Core.Config + -> EpochIndex + -> TossModifier + -> m () +normalizeToss coreConfig epoch TossModifier {..} = normalizeTossDo - pm + coreConfig epoch ( HM.toList (getCommitmentsMap _tmCommitments) , HM.toList _tmOpenings @@ -143,15 +150,18 @@ 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) + => Core.Config + -> EpochIndex + -> TossModifier + -> m () +refreshToss coreConfig 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 coreConfig epoch (comms, opens, shares, certs) takeMostValuable :: (MonadToss m, MonadTossEnv m) @@ -172,10 +182,13 @@ 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) + => Core.Config + -> EpochIndex + -> TossModifierLists + -> m () +normalizeTossDo coreConfig epoch (comms, opens, shares, certs) = do putsUseful $ map (flip CommitmentsPayload mempty . mkCommitmentsMapUnsafe . one) $ comms @@ -185,5 +198,6 @@ 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 coreConfig + (Left epoch) mapM_ verifyAndApply entries diff --git a/chain/src/Pos/Chain/Ssc/Toss/Pure.hs b/chain/src/Pos/Chain/Ssc/Toss/Pure.hs index a1cba312ecd..f50da16a105 100644 --- a/chain/src/Pos/Chain/Ssc/Toss/Pure.hs +++ b/chain/src/Pos/Chain/Ssc/Toss/Pure.hs @@ -25,8 +25,8 @@ import Pos.Chain.Ssc.Toss.Class (MonadToss (..), MonadTossEnv (..), import Pos.Chain.Ssc.Types (SscGlobalState, sgsCommitments, sgsOpenings, sgsShares, sgsVssCertificates) import qualified Pos.Chain.Ssc.VssCertData as VCD -import Pos.Core (EpochIndex, HasGenesisData, HasProtocolConstants, - crucialSlot, genesisVssCerts) +import Pos.Core (EpochIndex, HasGenesisData, crucialSlot, + genesisVssCerts) import Pos.Core.Update (BlockVersionData) import Pos.Util.Wlog (CanLog, HasLoggerName (..), LogEvent, NamedPureLogger (..), WithLogger, dispatchEvents, @@ -51,25 +51,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/chain/src/Pos/Chain/Ssc/Toss/Types.hs b/chain/src/Pos/Chain/Ssc/Toss/Types.hs index 4935c691e63..d18fde7e6d1 100644 --- a/chain/src/Pos/Chain/Ssc/Toss/Types.hs +++ b/chain/src/Pos/Chain/Ssc/Toss/Types.hs @@ -30,7 +30,7 @@ import Pos.Chain.Ssc.Base (deleteSignedCommitment, isOpeningId, isOpeningIdx, isSharesId, isSharesIdx) import Pos.Chain.Ssc.Toss.Class (MonadToss (..), MonadTossEnv (..), MonadTossRead (..)) -import Pos.Core (HasProtocolConstants, LocalSlotIndex, SlotId) +import Pos.Core (BlockCount, LocalSlotIndex, SlotId) import Pos.Core.Ssc (CommitmentsMap, OpeningsMap, SharesMap, VssCertificatesMap, insertVss) import Pos.Util.Util (cborError, ether) @@ -49,17 +49,17 @@ instance Buildable SscTag where build SharesMsg = "shares" build VssCertificateMsg = "VSS certificate" -isGoodSlotForTag :: HasProtocolConstants => SscTag -> LocalSlotIndex -> Bool +isGoodSlotForTag :: SscTag -> BlockCount -> LocalSlotIndex -> Bool isGoodSlotForTag CommitmentMsg = isCommitmentIdx isGoodSlotForTag OpeningMsg = isOpeningIdx isGoodSlotForTag SharesMsg = isSharesIdx -isGoodSlotForTag VssCertificateMsg = const True +isGoodSlotForTag VssCertificateMsg = const $ const True -isGoodSlotIdForTag :: HasProtocolConstants => SscTag -> SlotId -> Bool +isGoodSlotIdForTag :: SscTag -> BlockCount -> SlotId -> Bool isGoodSlotIdForTag CommitmentMsg = isCommitmentId isGoodSlotIdForTag OpeningMsg = isOpeningId isGoodSlotIdForTag SharesMsg = isSharesId -isGoodSlotIdForTag VssCertificateMsg = const True +isGoodSlotIdForTag VssCertificateMsg = const $ const True data TossModifier = TossModifier { _tmCommitments :: !CommitmentsMap @@ -118,7 +118,7 @@ instance MonadTossRead m => getOpenings = ether $ (<>) <$> use tmOpenings <*> getOpenings getShares = ether $ (<>) <$> use tmShares <*> getShares getVssCertificates = ether $ (<>) <$> use tmCertificates <*> getVssCertificates - getStableCertificates = ether . getStableCertificates + getStableCertificates k = ether . getStableCertificates k instance MonadTossEnv m => MonadTossEnv (TossT m) where diff --git a/chain/test/Test/Pos/Chain/Block/Arbitrary.hs b/chain/test/Test/Pos/Chain/Block/Arbitrary.hs index 151d226e316..70385123bd6 100644 --- a/chain/test/Test/Pos/Chain/Block/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Block/Arbitrary.hs @@ -32,8 +32,8 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, import Pos.Binary.Class (biSize) import Pos.Chain.Block (HeaderHash) import qualified Pos.Chain.Block as Block -import Pos.Core (GenesisHash (..), HasGenesisHash, - HasProtocolConstants, epochSlots, genesisHash) +import Pos.Core (GenesisHash (..), HasGenesisHash, genesisHash, + localSlotIndexMaxBound, localSlotIndexMinBound) import qualified Pos.Core as Core import Pos.Core.Attributes (areAttributesKnown) import qualified Pos.Core.Delegation as Core @@ -46,6 +46,7 @@ import Test.Pos.Chain.Ssc.Arbitrary (SscPayloadDependsOnSlot (..), import Test.Pos.Chain.Update.Arbitrary (genUpdatePayload) import Test.Pos.Core.Arbitrary (genSlotId) import Test.Pos.Core.Arbitrary.Txp (genTxPayload) +import Test.Pos.Core.Dummy (dummyEpochSlots) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) newtype BodyDependsOnSlot b = BodyDependsOnSlot @@ -56,11 +57,11 @@ newtype BodyDependsOnSlot b = BodyDependsOnSlot -- Arbitrary instances for Blockchain related types ------------------------------------------------------------------------------------------ -instance HasProtocolConstants => Arbitrary Block.BlockHeader where +instance Arbitrary Block.BlockHeader where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary Block.BlockSignature where +instance Arbitrary Block.BlockSignature where arbitrary = genericArbitrary shrink = genericShrink @@ -95,10 +96,7 @@ instance Arbitrary Block.GenesisBody where arbitrary = genericArbitrary shrink = genericShrink -instance ( HasProtocolConstants - , HasGenesisHash - ) => - Arbitrary Block.GenesisBlock where +instance HasGenesisHash => Arbitrary Block.GenesisBlock where arbitrary = Block.mkGenesisBlock dummyProtocolMagic <$> (maybe (Left (GenesisHash genesisHash)) Right <$> arbitrary) <*> arbitrary @@ -112,26 +110,25 @@ instance ( HasProtocolConstants -- | Generate a 'MainBlockHeader' given a parent hash, difficulty and body. genMainBlockHeader :: ProtocolMagic - -> Core.ProtocolConstants -> HeaderHash -> Core.ChainDifficulty -> Block.MainBody -> Gen Block.MainBlockHeader -genMainBlockHeader pm pc prevHash difficulty body = +genMainBlockHeader pm prevHash difficulty body = Block.mkMainHeaderExplicit pm <$> pure prevHash <*> pure difficulty - <*> genSlotId pc + <*> genSlotId dummyEpochSlots <*> arbitrary -- SecretKey <*> pure Nothing <*> pure body <*> arbitrary -instance HasProtocolConstants => Arbitrary Block.MainBlockHeader where +instance Arbitrary Block.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 Block.MainExtraHeaderData where @@ -150,11 +147,11 @@ instance Arbitrary Block.MainProof where shrink (mpTxProof, mpMpcProof, mpProxySKsProof, mpUpdateProof) ] -instance HasProtocolConstants => Arbitrary Block.MainConsensusData where +instance Arbitrary Block.MainConsensusData where arbitrary = genericArbitrary shrink = genericShrink -instance (HasProtocolConstants) => Arbitrary Block.MainToSign where +instance Arbitrary Block.MainToSign where arbitrary = genericArbitrary shrink = genericShrink @@ -185,18 +182,16 @@ genMainBlockBody pm epoch = genMainBlockBodyForSlot :: ProtocolMagic - -> Core.ProtocolConstants -> Core.SlotId -> Gen Block.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 $ Block.MainBody txpPayload sscPayload dlgPayload updPayload -instance HasProtocolConstants => - Arbitrary (BodyDependsOnSlot Block.MainBlockchain) where +instance Arbitrary (BodyDependsOnSlot Block.MainBlockchain) where arbitrary = pure $ BodyDependsOnSlot $ \slotId -> do txPayload <- arbitrary generator <- genPayloadDependsOnSlot <$> arbitrary @@ -220,13 +215,12 @@ instance Arbitrary Block.MainBody where -- You choose the previous header hash. genMainBlock :: ProtocolMagic - -> Core.ProtocolConstants -> HeaderHash -> Core.ChainDifficulty -> Gen Block.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 <- Block.MainExtraHeaderData <$> arbitrary @@ -240,10 +234,7 @@ genMainBlock pm pc prevHash difficulty = do <*> pure extraHeaderData pure $ Block.UnsafeGenericBlock header body extraBodyData -instance ( HasProtocolConstants - , HasGenesisHash - ) => - Arbitrary Block.MainBlock where +instance HasGenesisHash => Arbitrary Block.MainBlock where arbitrary = do slot <- arbitrary BodyDependsOnSlot {..} <- arbitrary :: Gen (BodyDependsOnSlot Block.MainBlockchain) @@ -300,13 +291,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] @@ -372,18 +357,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 @@ -400,8 +381,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 @@ -423,8 +404,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 @@ -444,7 +424,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 @@ -469,8 +449,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 = diff --git a/chain/test/Test/Pos/Chain/Block/Arbitrary/Generate.hs b/chain/test/Test/Pos/Chain/Block/Arbitrary/Generate.hs index 08791db8e5f..c9bd1597159 100644 --- a/chain/test/Test/Pos/Chain/Block/Arbitrary/Generate.hs +++ b/chain/test/Test/Pos/Chain/Block/Arbitrary/Generate.hs @@ -14,8 +14,7 @@ import qualified Test.QuickCheck.Gen as QC import qualified Test.QuickCheck.Random as QC import Pos.Chain.Block (MainBlock) -import Pos.Core (HasGenesisHash, HasProtocolConstants, - ProtocolConstants, ProtocolMagic) +import Pos.Core (HasGenesisHash, ProtocolMagic) -- Also brings in the 'Arbitrary' instance for 'MainBlock'. import Test.Pos.Chain.Block.Arbitrary (genMainBlock) @@ -23,9 +22,7 @@ import Test.Pos.Chain.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 @@ -36,16 +33,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/chain/test/Test/Pos/Chain/Block/Bi.hs b/chain/test/Test/Pos/Chain/Block/Bi.hs index 1ee501e4f9d..39c5cdbd949 100644 --- a/chain/test/Test/Pos/Chain/Block/Bi.hs +++ b/chain/test/Test/Pos/Chain/Block/Bi.hs @@ -33,7 +33,7 @@ import Test.Pos.Core.ExampleHelpers (exampleBlockVersion, exampleSlotLeaders, exampleSoftwareVersion, exampleSscPayload, exampleSscProof, exampleTxPayload, exampleTxProof, exampleUpdatePayload, exampleUpdateProof, - feedPM, feedPMC, staticHeavyDlgIndexes, + feedPM, feedPMEpochSlots, staticHeavyDlgIndexes, staticProxySKHeavys) import Test.Pos.Util.Golden (discoverGolden, eachOf) import Test.Pos.Util.Tripping (discoverRoundTrip) @@ -63,7 +63,8 @@ golden_BlockHeaderMain = goldenTestBi exampleBlockHeaderMain "test/golden/BlockHeaderMain" roundTripBlockHeaderBi :: Property -roundTripBlockHeaderBi = eachOf 10 (feedPMC genBlockHeader) roundTripsBiBuildable +roundTripBlockHeaderBi = + eachOf 10 (feedPMEpochSlots genBlockHeader) roundTripsBiBuildable -------------------------------------------------------------------------------- -- BlockHeaderAttributes @@ -90,7 +91,8 @@ golden_BlockSignature_Heavy = goldenTestBi exampleBlockPSignatureHeavy "test/golden/BlockSignature_Heavy" roundTripBlockSignatureBi :: Property -roundTripBlockSignatureBi = eachOf 10 (feedPMC genBlockSignature) roundTripsBiBuildable +roundTripBlockSignatureBi = + eachOf 10 (feedPMEpochSlots genBlockSignature) roundTripsBiBuildable -------------------------------------------------------------------------------- -- GenesisBlockHeader @@ -147,7 +149,8 @@ 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 @@ -167,7 +170,8 @@ golden_MainConsensusData = goldenTestBi mcd "test/golden/MainConsensusData" exampleChainDifficulty exampleBlockSignature roundTripMainConsensusData :: Property -roundTripMainConsensusData = eachOf 20 (feedPMC genMainConsensusData) roundTripsBiShow +roundTripMainConsensusData = + eachOf 20 (feedPMEpochSlots genMainConsensusData) roundTripsBiShow -------------------------------------------------------------------------------- -- MainExtraBodyData @@ -205,7 +209,8 @@ golden_MainToSign :: Property golden_MainToSign = goldenTestBi exampleMainToSign "test/golden/MainToSign" roundTripMainToSignBi :: Property -roundTripMainToSignBi = eachOf 20 (feedPMC genMainToSign) roundTripsBiShow +roundTripMainToSignBi = + eachOf 20 (feedPMEpochSlots genMainToSign) roundTripsBiShow -------------------------------------------------------------------------------- -- Example golden datatypes diff --git a/chain/test/Test/Pos/Chain/Block/BlockSpec.hs b/chain/test/Test/Pos/Chain/Block/BlockSpec.hs index a4eceede441..75ee36e421d 100644 --- a/chain/test/Test/Pos/Chain/Block/BlockSpec.hs +++ b/chain/test/Test/Pos/Chain/Block/BlockSpec.hs @@ -56,12 +56,10 @@ spec = withGenesisSpec 0 defaultCoreConfiguration id $ \_ -> prop verifyHeadersDesc validateGoodHeaderChain emptyHeaderChain (NewestFirst []) where - mainHeaderFormationDesc - = "Manually generating a main header block and using\ - \ mkMainHeader is the same" - genesisHeaderFormationDesc - = "Manually generating a genesis header block and using\ - \ mkGenesisHeader is the same" + mainHeaderFormationDesc = + "Manually generating a main header block and using mkMainHeader is the same" + genesisHeaderFormationDesc = + "Manually generating a genesis header block and using mkGenesisHeader is the same" verifyHeaderDesc = "Successfully verifies a correct main block header" invalidProtocolMagicHeaderDesc = "Header with invalid protocol magic does not validate" diff --git a/chain/test/Test/Pos/Chain/Block/CborSpec.hs b/chain/test/Test/Pos/Chain/Block/CborSpec.hs index fb5424e5e52..d46893cd358 100644 --- a/chain/test/Test/Pos/Chain/Block/CborSpec.hs +++ b/chain/test/Test/Pos/Chain/Block/CborSpec.hs @@ -10,16 +10,13 @@ import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (modifyMaxSuccess) import qualified Pos.Chain.Block as Core -import Pos.Core.Configuration (defaultCoreConfiguration, - withGenesisSpec) import Test.Pos.Binary.Helpers (binaryTest) import Test.Pos.Chain.Block.Arbitrary () import Test.Pos.Core.Arbitrary () spec :: Spec -spec = withGenesisSpec 0 defaultCoreConfiguration id $ \_ -> - describe "Cbor.Bi instances" $ do +spec = describe "Cbor.Bi instances" $ do -- These data types are defined in the 'core' package which suggests that -- these tests should be there, but they depend on type in eg 'update' so -- that is not possible. diff --git a/chain/test/Test/Pos/Chain/Block/Gen.hs b/chain/test/Test/Pos/Chain/Block/Gen.hs index 9ae52263a2d..b0c49c13423 100644 --- a/chain/test/Test/Pos/Chain/Block/Gen.hs +++ b/chain/test/Test/Pos/Chain/Block/Gen.hs @@ -32,7 +32,7 @@ import Pos.Chain.Block (BlockBodyAttributes, BlockHeader (..), MainExtraBodyData (..), MainExtraHeaderData (..), MainProof (..), MainToSign (..), mkGenericHeader, mkMainHeaderExplicit) -import Pos.Core (ProtocolConstants, ProtocolMagic) +import Pos.Core (ProtocolMagic, SlotCount) import Pos.Core.Attributes (mkAttributes) import Test.Pos.Core.Gen (genBlockVersion, genChainDifficulty, @@ -47,17 +47,17 @@ import Test.Pos.Crypto.Gen (genAbstractHash, genProxySignature, 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 @@ -67,7 +67,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 @@ -105,24 +105,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 @@ -144,11 +144,11 @@ 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 diff --git a/chain/test/Test/Pos/Chain/Block/SafeCopySpec.hs b/chain/test/Test/Pos/Chain/Block/SafeCopySpec.hs index 0273e3e589d..3b469b0b5de 100644 --- a/chain/test/Test/Pos/Chain/Block/SafeCopySpec.hs +++ b/chain/test/Test/Pos/Chain/Block/SafeCopySpec.hs @@ -10,14 +10,12 @@ import Test.Hspec (Spec, describe) import Universum import qualified Pos.Chain.Block as Core -import Pos.Core.Configuration (defaultCoreConfiguration, - withGenesisSpec) import Test.Pos.Binary.Helpers (safeCopyTest) import Test.Pos.Chain.Block.Arbitrary () spec :: Spec -spec = withGenesisSpec 0 defaultCoreConfiguration id $ \_ -> describe "Block types" $ do +spec = describe "Block types" $ do -- These types are defined in 'core' but the 'Arbitrary' instances require -- generator components defined in package like 'ssc' and 'update' which -- means these tests cannot be moved to 'core'. diff --git a/chain/test/Test/Pos/Chain/Lrc/FtsSpec.hs b/chain/test/Test/Pos/Chain/Lrc/FtsSpec.hs index c8a66ce2dac..0737a0e536a 100644 --- a/chain/test/Test/Pos/Chain/Lrc/FtsSpec.hs +++ b/chain/test/Test/Pos/Chain/Lrc/FtsSpec.hs @@ -15,26 +15,21 @@ import Test.QuickCheck (Arbitrary (..), Property, choose, infiniteListOf, suchThat, (===)) import Pos.Chain.Lrc (followTheSatoshi) -import Pos.Core (BlockCount, Coin, SharedSeed, SlotCount, - StakeholderId, StakesList, addressHash, mkCoin, sumCoins, - unsafeAddCoin, unsafeIntegerToCoin) +import Pos.Core (Coin, SharedSeed, StakeholderId, StakesList, + addressHash, mkCoin, pcK, sumCoins, unsafeAddCoin, + unsafeIntegerToCoin) import Pos.Crypto (PublicKey) 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 +93,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 +179,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/chain/test/Test/Pos/Chain/Ssc/Arbitrary.hs b/chain/test/Test/Pos/Chain/Ssc/Arbitrary.hs index 58beb28160e..24ba78eb15b 100644 --- a/chain/test/Test/Pos/Chain/Ssc/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Ssc/Arbitrary.hs @@ -37,12 +37,9 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, import Pos.Chain.Ssc (MCCommitment (..), MCOpening (..), MCShares (..), MCVssCertificate (..), SscGlobalState (..), SscSecretStorage (..), SscTag (..), TossModifier (..), - VssCertData (..), isCommitmentIdExplicit, - isOpeningIdExplicit, isSharesIdExplicit, + VssCertData (..), isCommitmentId, isOpeningId, isSharesId, mkSignedCommitment) import Pos.Core (EpochIndex, SlotId (..)) -import Pos.Core.Configuration (HasProtocolConstants, - protocolConstants) import Pos.Core.ProtocolConstants (ProtocolConstants (..), VssMaxTTL (..), VssMinTTL (..)) import Pos.Core.Ssc (Commitment (..), CommitmentsMap, Opening (..), @@ -55,6 +52,7 @@ import Pos.Crypto (ProtocolMagic, SecretKey, deterministic, 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 (..), @@ -186,13 +184,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) @@ -209,8 +207,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 @@ -221,11 +219,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/chain/test/Test/Pos/Chain/Txp/Toil/UtxoSpec.hs b/chain/test/Test/Pos/Chain/Txp/Toil/UtxoSpec.hs index 6b3638378df..ef3b8d7d421 100644 --- a/chain/test/Test/Pos/Chain/Txp/Toil/UtxoSpec.hs +++ b/chain/test/Test/Pos/Chain/Txp/Toil/UtxoSpec.hs @@ -30,15 +30,15 @@ import Pos.Chain.Script.Examples (alwaysSuccessValidator, import Pos.Chain.Txp (ToilVerFailure (..), Utxo, VTxContext (..), VerifyTxUtxoRes, WitnessVerFailure (..), applyTxToUtxo, evalUtxoM, execUtxoM, utxoGet, utxoToLookup, verifyTxUtxo) -import Pos.Core (HasConfiguration, addressHash, checkPubKeyAddress, - defaultCoreConfiguration, makePubKeyAddressBoot, - makeScriptAddress, mkCoin, sumCoins, withGenesisSpec) +import Pos.Core (addressHash, checkPubKeyAddress, + makePubKeyAddressBoot, makeScriptAddress, mkCoin, + sumCoins) import Pos.Core.Attributes (mkAttributes) import Pos.Core.Txp (Tx (..), TxAux (..), TxIn (..), TxInWitness (..), TxOut (..), TxOutAux (..), TxSigData (..), TxWitness, isTxInUnknown) -import Pos.Crypto (ProtocolMagic, SignTag (SignTx), checkSig, - fakeSigner, hash, toPublic, unsafeHash, withHash) +import Pos.Crypto (SignTag (SignTx), checkSig, fakeSigner, hash, + toPublic, unsafeHash, withHash) import qualified Pos.Util.Modifier as MM import Test.Pos.Core.Arbitrary.Txp (BadSigsTx (..), @@ -53,21 +53,19 @@ import Test.Pos.Util.QuickCheck.Property (qcIsLeft, qcIsRight) ---------------------------------------------------------------------------- spec :: Spec -spec = - withGenesisSpec 0 defaultCoreConfiguration identity - $ \_ -> describe "Txp.Toil.Utxo" $ do - describe "utxoGet (no modifier)" $ do - it "returns Nothing when given empty Utxo" - $ isNothing (utxoGetSimple mempty myTxIn) - prop description_findTxInUtxo findTxInUtxo - describe "verifyTxUtxo" $ do - prop description_verifyTxInUtxo (verifyTxInUtxo dummyProtocolMagic) - prop description_validateGoodTx (validateGoodTx dummyProtocolMagic) - prop description_badSigsTx (badSigsTx dummyProtocolMagic) - prop description_doubleInputTx doubleInputTx - describe "applyTxToUtxo" $ do - prop description_applyTxToUtxoGood applyTxToUtxoGood - scriptTxSpec dummyProtocolMagic +spec = describe "Txp.Toil.Utxo" $ do + describe "utxoGet (no modifier)" $ do + it "returns Nothing when given empty Utxo" + $ isNothing (utxoGetSimple mempty myTxIn) + prop description_findTxInUtxo findTxInUtxo + describe "verifyTxUtxo" $ do + prop description_verifyTxInUtxo verifyTxInUtxo + prop description_validateGoodTx validateGoodTx + prop description_badSigsTx badSigsTx + prop description_doubleInputTx doubleInputTx + describe "applyTxToUtxo" $ do + prop description_applyTxToUtxoGood applyTxToUtxoGood + scriptTxSpec where myTxIn = TxInUtxo myHash 0 myHash = unsafeHash @Int32 0 @@ -98,8 +96,8 @@ findTxInUtxo key txO utxo = in (isJust $ utxoGetSimple newUtxo key) && (isNothing $ utxoGetSimple utxo' key) -verifyTxInUtxo :: ProtocolMagic -> SmallGenerator GoodTx -> Property -verifyTxInUtxo pm (SmallGenerator (GoodTx ls)) = +verifyTxInUtxo :: SmallGenerator GoodTx -> Property +verifyTxInUtxo (SmallGenerator (GoodTx ls)) = let txs = fmap (view _1) ls witness = V.fromList $ toList $ fmap (view _4) ls (ins, outs) = NE.unzip $ map (\(_, tIs, tOs, _) -> (tIs, tOs)) ls @@ -113,39 +111,36 @@ verifyTxInUtxo pm (SmallGenerator (GoodTx ls)) = txAux = TxAux newTx witness in counterexample ("\n"+|nameF "txs" (blockListF' "-" genericF txs)|+"" +|nameF "transaction" (B.build txAux)|+"") $ - qcIsRight $ verifyTxUtxoSimple dummyProtocolMagic vtxContext utxo txAux + qcIsRight $ verifyTxUtxoSimple vtxContext utxo txAux -badSigsTx :: ProtocolMagic -> SmallGenerator BadSigsTx -> Property -badSigsTx pm (SmallGenerator (getBadSigsTx -> ls)) = +badSigsTx :: SmallGenerator BadSigsTx -> Property +badSigsTx (SmallGenerator (getBadSigsTx -> ls)) = let (tx@UnsafeTx {..}, utxo, extendedInputs, txWits) = getTxFromGoodTx ls ctx = VTxContext False - transactionVerRes = - verifyTxUtxoSimple dummyProtocolMagic ctx utxo $ TxAux tx txWits + transactionVerRes = verifyTxUtxoSimple ctx utxo $ TxAux tx txWits notAllSignaturesAreValid = - any (signatureIsNotValid dummyProtocolMagic tx) + any (signatureIsNotValid tx) (NE.zip (NE.fromList (toList txWits)) (map (fmap snd) extendedInputs)) in notAllSignaturesAreValid ==> qcIsLeft transactionVerRes -doubleInputTx :: ProtocolMagic -> SmallGenerator DoubleInputTx -> Property -doubleInputTx pm (SmallGenerator (getDoubleInputTx -> ls)) = +doubleInputTx :: SmallGenerator DoubleInputTx -> Property +doubleInputTx (SmallGenerator (getDoubleInputTx -> ls)) = let ((tx@UnsafeTx {..}), utxo, _extendedInputs, txWits) = getTxFromGoodTx ls ctx = VTxContext False - transactionVerRes = - verifyTxUtxoSimple dummyProtocolMagic ctx utxo $ TxAux tx txWits + transactionVerRes = verifyTxUtxoSimple ctx utxo $ TxAux tx txWits someInputsAreDuplicated = not $ allDistinct (toList _txInputs) in someInputsAreDuplicated ==> qcIsLeft transactionVerRes -validateGoodTx :: ProtocolMagic -> SmallGenerator GoodTx -> Property -validateGoodTx pm (SmallGenerator (getGoodTx -> ls)) = +validateGoodTx :: SmallGenerator GoodTx -> Property +validateGoodTx (SmallGenerator (getGoodTx -> ls)) = let quadruple@(tx, utxo, _, txWits) = getTxFromGoodTx ls ctx = VTxContext False - transactionVerRes = - verifyTxUtxoSimple dummyProtocolMagic ctx utxo $ TxAux tx txWits - transactionReallyIsGood = individualTxPropertyVerifier dummyProtocolMagic quadruple + transactionVerRes = verifyTxUtxoSimple ctx utxo $ TxAux tx txWits + transactionReallyIsGood = individualTxPropertyVerifier quadruple in transactionReallyIsGood ==> qcIsRight transactionVerRes ---------------------------------------------------------------------------- @@ -156,12 +151,11 @@ utxoGetSimple :: Utxo -> TxIn -> Maybe TxOutAux utxoGetSimple utxo txIn = evalUtxoM mempty (utxoToLookup utxo) (utxoGet txIn) verifyTxUtxoSimple - :: ProtocolMagic - -> VTxContext + :: VTxContext -> Utxo -> TxAux -> Either ToilVerFailure VerifyTxUtxoRes -verifyTxUtxoSimple pm ctx utxo txAux = +verifyTxUtxoSimple ctx utxo txAux = evalUtxoM mempty (utxoToLookup utxo) . runExceptT $ verifyTxUtxo dummyProtocolMagic ctx mempty txAux @@ -200,30 +194,28 @@ getTxFromGoodTx ls = -- * every input is signed properly; -- * every input is a known unspent output. -- It also checks that it has good structure w.r.t. 'verifyTxAlone'. -individualTxPropertyVerifier :: ProtocolMagic -> TxVerifyingTools -> Bool -individualTxPropertyVerifier pm (tx@UnsafeTx{..}, _, extendedInputs, txWits) = +individualTxPropertyVerifier :: TxVerifyingTools -> Bool +individualTxPropertyVerifier (tx@UnsafeTx{..}, _, extendedInputs, txWits) = let hasGoodSum = txChecksum extendedInputs _txOutputs hasGoodInputs = - all (signatureIsValid dummyProtocolMagic tx) + all (signatureIsValid tx) (NE.zip (NE.fromList (toList txWits)) (map (fmap snd) extendedInputs)) in hasGoodSum && hasGoodInputs signatureIsValid - :: ProtocolMagic - -> Tx + :: Tx -> (TxInWitness, Maybe TxOutAux) -- ^ input witness + output spent by the input -> Bool -signatureIsValid pm tx (PkWitness twKey twSig, Just TxOutAux{..}) = +signatureIsValid tx (PkWitness twKey twSig, Just TxOutAux{..}) = let txSigData = TxSigData { txSigTxHash = hash tx } in checkPubKeyAddress twKey (txOutAddress toaOut) && checkSig dummyProtocolMagic SignTx twKey txSigData twSig -signatureIsValid _ _ _ = False +signatureIsValid _ _ = False -signatureIsNotValid - :: ProtocolMagic -> Tx -> (TxInWitness, Maybe TxOutAux) -> Bool +signatureIsNotValid :: Tx -> (TxInWitness, Maybe TxOutAux) -> Bool signatureIsNotValid = not ... signatureIsValid -- | This function takes a list of resolved inputs from a transaction, that @@ -264,8 +256,8 @@ applyTxToUtxoGood (txIn0, txOut0) txMap txOuts = -- Script Txs spec ---------------------------------------------------------------------------- -scriptTxSpec :: ProtocolMagic -> Spec -scriptTxSpec pm = describe "script transactions" $ do +scriptTxSpec :: Spec +scriptTxSpec = describe "script transactions" $ do describe "good cases" $ do it "goodIntRedeemer + intValidator" $ do txShouldSucceed $ checkScriptTx diff --git a/client/Makefile b/client/Makefile new file mode 100644 index 00000000000..b63854b6584 --- /dev/null +++ b/client/Makefile @@ -0,0 +1,13 @@ +help: ## Print documentation + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +ghcid: ## Run ghcid with the cardano-sl-client package + ghcid \ + --command "stack ghci cardano-sl-client --ghci-options=-fno-code" + +ghcid-test: ## Have ghcid run the test suite for the wallet-new-specs on successful recompile + ghcid \ + --command "stack ghci cardano-sl-client:lib cardano-sl-client:test:cardano-client-test --ghci-options=-fobject-code" \ + --test "Main.main" + +.PHONY: ghcid ghcid-test help diff --git a/client/cardano-sl-client.cabal b/client/cardano-sl-client.cabal index a98d01029cf..c048c6320a2 100644 --- a/client/cardano-sl-client.cabal +++ b/client/cardano-sl-client.cabal @@ -99,6 +99,7 @@ test-suite cardano-client-test , cardano-sl-chain , 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 5443c4277cf..924362459b0 100644 --- a/client/src/Pos/Client/Txp/History.hs +++ b/client/src/Pos/Client/Txp/History.hs @@ -45,11 +45,11 @@ import Pos.Chain.Txp (ToilVerFailure, Tx (..), TxAux (..), TxId, applyTxToUtxo, evalUtxoM, flattenTxPayload, genesisUtxo, runUtxoM, topsortTxs, txOutAddress, unGenesisUtxo, utxoGet, utxoToLookup) -import Pos.Core (Address, ChainDifficulty, GenesisHash (..), - HasConfiguration, Timestamp (..), difficultyL, epochSlots, - genesisHash) +import Pos.Core as Core (Address, ChainDifficulty, Config (..), + GenesisHash (..), HasConfiguration, Timestamp (..), + configEpochSlots, difficultyL, genesisHash) import Pos.Core.JsonLog (CanJsonLog (..)) -import Pos.Crypto (ProtocolMagic, WithHash (..), withHash) +import Pos.Crypto (WithHash (..), withHash) import Pos.DB (MonadDBRead, MonadGState) import Pos.DB.Block (getBlock) import Pos.DB.Txp (MempoolExt, MonadTxpLocal, MonadTxpMem, buildUtxo, @@ -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) + :: Core.Config -> [Address] -> m (Map TxId TxHistoryEntry) getLocalHistory :: [Address] -> m (Map TxId TxHistoryEntry) - saveTx :: ProtocolMagic -> TxpConfiguration -> (TxId, TxAux) -> m () + saveTx :: Core.Config -> TxpConfiguration -> (TxId, TxAux) -> m () default getBlockHistory :: (MonadTrans t, MonadTxHistory m', t m' ~ m) - => ProtocolMagic -> [Address] -> m (Map TxId TxHistoryEntry) - getBlockHistory pm = lift . getBlockHistory pm + => Core.Config -> [Address] -> m (Map TxId TxHistoryEntry) + getBlockHistory coreConfig = lift . getBlockHistory coreConfig default getLocalHistory :: (MonadTrans t, MonadTxHistory m', t m' ~ m) @@ -188,11 +188,11 @@ class (Monad m, HasConfiguration) => MonadTxHistory m where default saveTx :: (MonadTrans t, MonadTxHistory m', t m' ~ m) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxId, TxAux) -> m () - saveTx pm txpConfig = lift . saveTx pm txpConfig + saveTx coreConfig txpConfig = lift . saveTx coreConfig txpConfig instance {-# OVERLAPPABLE #-} (MonadTxHistory m, MonadTrans t, Monad (t m)) => @@ -216,11 +216,14 @@ type TxHistoryEnv ctx m = getBlockHistoryDefault :: forall ctx m . (HasConfiguration, TxHistoryEnv ctx m) - => ProtocolMagic + => Core.Config -> [Address] -> m (Map TxId TxHistoryEntry) -getBlockHistoryDefault pm addrs = do - let bot = headerHash (genesisBlock0 pm (GenesisHash genesisHash) (genesisLeaders epochSlots)) +getBlockHistoryDefault coreConfig addrs = do + let bot = headerHash $ genesisBlock0 + (configProtocolMagic coreConfig) + (GenesisHash genesisHash) + (genesisLeaders $ configEpochSlots coreConfig) sd <- GS.getSlottingData systemStart <- getSystemStartM @@ -268,11 +271,11 @@ instance Exception SaveTxException where SaveTxToilFailure x -> toString (pretty x) saveTxDefault :: TxHistoryEnv ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxId, TxAux) -> m () -saveTxDefault pm txpConfig txw = do - res <- txpProcessTx pm txpConfig txw +saveTxDefault coreConfig txpConfig txw = do + res <- txpProcessTx coreConfig txpConfig 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 737a9f10d6c..a7c4df0b291 100644 --- a/client/src/Pos/Client/Txp/Network.hs +++ b/client/src/Pos/Client/Txp/Network.hs @@ -24,8 +24,8 @@ import Pos.Client.Txp.Util (InputSelectionPolicy, PendingAddresses (..), TxCreateMode, TxError (..), createMTx, createRedemptionTx, createUnsignedTx) import Pos.Communication.Types (InvOrDataTK) -import Pos.Core (Address, Coin, makeRedeemAddress, mkCoin, - unsafeAddCoin) +import Pos.Core as Core (Address, Coin, Config, makeRedeemAddress, + mkCoin, unsafeAddCoin) import Pos.Core.Txp (Tx, TxAux (..), TxId, TxMsgContents (..), TxOut (..), TxOutAux (..), txaF) import Pos.Crypto (ProtocolMagic, RedeemSecretKey, SafeSigner, hash, @@ -49,7 +49,7 @@ type TxMode m -- | Construct Tx using multiple secret keys and given list of desired outputs. prepareMTx :: TxMode m - => ProtocolMagic + => Core.Config -> (Address -> Maybe SafeSigner) -> PendingAddresses -> InputSelectionPolicy @@ -57,23 +57,24 @@ prepareMTx -> NonEmpty TxOutAux -> AddrData m -> m (TxAux, NonEmpty TxOut) -prepareMTx pm hdwSigners pendingAddrs inputSelectionPolicy addrs outputs addrData = do +prepareMTx coreConfig hdwSigners pendingAddrs inputSelectionPolicy addrs outputs addrData = do utxo <- getOwnUtxos (toList addrs) - eitherToThrow =<< createMTx pm pendingAddrs inputSelectionPolicy utxo hdwSigners outputs addrData + eitherToThrow =<< + createMTx coreConfig pendingAddrs inputSelectionPolicy utxo hdwSigners outputs addrData -- | Construct unsigned Tx prepareUnsignedTx :: TxMode m - => ProtocolMagic + => Core.Config -> PendingAddresses -> InputSelectionPolicy -> NonEmpty Address -> NonEmpty TxOutAux -> Address -> m (Either TxError (Tx, NonEmpty TxOut)) -prepareUnsignedTx pm pendingAddrs inputSelectionPolicy addrs outputs changeAddress = do +prepareUnsignedTx coreConfig pendingAddrs inputSelectionPolicy addrs outputs changeAddress = do utxo <- getOwnUtxos (toList addrs) - createUnsignedTx pm pendingAddrs inputSelectionPolicy utxo outputs changeAddress + createUnsignedTx coreConfig pendingAddrs inputSelectionPolicy utxo outputs changeAddress -- | 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 32ad86fa1e8..63b30204889 100644 --- a/client/src/Pos/Client/Txp/Util.hs +++ b/client/src/Pos/Client/Txp/Util.hs @@ -70,8 +70,9 @@ import Pos.Chain.Txp (Tx (..), TxAux (..), TxFee (..), TxIn (..), TxInWitness (..), TxOut (..), TxOutAux (..), TxSigData (..), Utxo) import Pos.Client.Txp.Addresses (MonadAddresses (..)) -import Pos.Core (Address, Coin, StakeholderId, TxFeePolicy (..), - TxSizeLinear (..), calculateTxSizeLinear, coinToInteger, +import Pos.Core as Core (Address, Coin, Config (..), SlotCount, + StakeholderId, TxFeePolicy (..), TxSizeLinear (..), + calculateTxSizeLinear, coinToInteger, configEpochSlots, integerToCoin, isRedeemAddress, mkCoin, sumCoins, txSizeLinearMinValue, unsafeIntegerToCoin, unsafeSubCoin) import Pos.Core.Attributes (mkAttributes) @@ -528,13 +529,14 @@ 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 @@ -553,33 +555,34 @@ mkOutputsWithRemForUnsignedTx TxRaw {..} changeAddress prepareInpsOuts :: TxCreateMode m - => ProtocolMagic + => Core.Config -> 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 coreConfig pendingTx utxo outputs addrData = do + txRaw@TxRaw {..} <- prepareTxWithFee coreConfig pendingTx utxo outputs + outputsWithRem <- + mkOutputsWithRem (configEpochSlots coreConfig) addrData txRaw pure (trInputs, outputsWithRem) prepareInpsOutsForUnsignedTx :: TxCreateMode m - => ProtocolMagic + => Core.Config -> PendingAddresses -> Utxo -> TxOutputs -> Address -> TxCreator m (TxOwnedInputs TxOut, TxOutputs) -prepareInpsOutsForUnsignedTx pm pendingTx utxo outputs changeAddress = do - txRaw@TxRaw {..} <- prepareTxWithFee pm pendingTx utxo outputs +prepareInpsOutsForUnsignedTx coreConfig pendingTx utxo outputs changeAddress = do + txRaw@TxRaw {..} <- prepareTxWithFee coreConfig pendingTx utxo outputs let outputsWithRem = mkOutputsWithRemForUnsignedTx txRaw changeAddress pure (trInputs, outputsWithRem) createGenericTx :: TxCreateMode m - => ProtocolMagic + => Core.Config -> PendingAddresses -> (TxOwnedInputs TxOut -> TxOutputs -> Either TxError TxAux) -> InputSelectionPolicy @@ -587,15 +590,15 @@ 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 coreConfig pendingTx creator inputSelectionPolicy utxo outputs addrData + = runTxCreator inputSelectionPolicy $ do + (inps, outs) <- prepareInpsOuts coreConfig pendingTx utxo outputs addrData txAux <- either throwError return $ creator inps outs pure (txAux, map fst inps) createGenericTxSingle :: TxCreateMode m - => ProtocolMagic + => Core.Config -> PendingAddresses -> (TxInputs -> TxOutputs -> Either TxError TxAux) -> InputSelectionPolicy @@ -603,13 +606,14 @@ createGenericTxSingle -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createGenericTxSingle pm pendingTx creator = createGenericTx pm pendingTx (creator . map snd) +createGenericTxSingle coreConfig pendingTx creator = + createGenericTx coreConfig 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 + => Core.Config -> PendingAddresses -> InputSelectionPolicy -> Utxo @@ -617,9 +621,15 @@ 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 coreConfig pendingTx groupInputs utxo hdwSigners outputs addrData = + createGenericTx + coreConfig + pendingTx + (makeMPubKeyTxAddrs (configProtocolMagic coreConfig) getSigner) + groupInputs + utxo + outputs + addrData where getSigner address = note (SafeSignerNotFound address) $ @@ -629,30 +639,35 @@ createMTx pm pendingTx groupInputs utxo hdwSigners outputs addrData = -- outputs. createTx :: TxCreateMode m - => ProtocolMagic + => Core.Config -> 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 coreConfig pendingTx utxo ss outputs addrData = createGenericTxSingle + coreConfig + pendingTx + (\i o -> Right $ makePubKeyTx (configProtocolMagic coreConfig) ss i o) + OptimizeForHighThroughput + utxo + outputs + addrData -- | Create unsigned Tx, it will be signed by external wallet. createUnsignedTx :: TxCreateMode m - => ProtocolMagic + => Core.Config -> PendingAddresses -> InputSelectionPolicy -> Utxo -> TxOutputs -> Address -> m (Either TxError (Tx,NonEmpty TxOut)) -createUnsignedTx pm pendingTx selectionPolicy utxo outputs changeAddress = +createUnsignedTx coreConfig pendingTx selectionPolicy utxo outputs changeAddress = runTxCreator selectionPolicy $ do - (inps, outs) <- prepareInpsOutsForUnsignedTx pm + (inps, outs) <- prepareInpsOutsForUnsignedTx coreConfig pendingTx utxo outputs @@ -663,17 +678,20 @@ createUnsignedTx pm pendingTx selectionPolicy utxo outputs changeAddress = -- | Make a transaction, using M-of-N script as a source createMOfNTx :: TxCreateMode m - => ProtocolMagic + => Core.Config -> 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) +createMOfNTx coreConfig pendingTx utxo keys outputs addrData = + createGenericTxSingle coreConfig + pendingTx + (\i o -> Right $ makeMOfNTx pm validator sks i o) OptimizeForSecurity utxo outputs addrData where + pm = configProtocolMagic coreConfig ids = map fst keys sks = map snd keys m = length $ filter isJust sks @@ -714,25 +732,26 @@ withLinearFeePolicy action = view tcdFeePolicy >>= \case -- | Prepare transaction considering fees prepareTxWithFee :: MonadAddresses m - => ProtocolMagic + => Core.Config -> PendingAddresses -> Utxo -> TxOutputs -> TxCreator m TxRaw -prepareTxWithFee pm pendingTx utxo outputs = withLinearFeePolicy $ \linearPolicy -> - stabilizeTxFee pm pendingTx linearPolicy utxo outputs +prepareTxWithFee coreConfig pendingTx utxo outputs = + withLinearFeePolicy $ \linearPolicy -> + stabilizeTxFee coreConfig pendingTx linearPolicy utxo outputs -- | Compute, how much fees we should pay to send money to given -- outputs computeTxFee :: MonadAddresses m - => ProtocolMagic + => Core.Config -> PendingAddresses -> Utxo -> TxOutputs -> TxCreator m TxFee -computeTxFee pm pendingTx utxo outputs = do - TxRaw {..} <- prepareTxWithFee pm pendingTx utxo outputs +computeTxFee coreConfig pendingTx utxo outputs = do + TxRaw {..} <- prepareTxWithFee coreConfig pendingTx utxo outputs let outAmount = sumTxOutCoins trOutputs inAmount = sumCoins $ map (txOutValue . fst) trInputs remaining = coinToInteger trRemainingMoney @@ -785,13 +804,13 @@ computeTxFee pm pendingTx utxo outputs = do stabilizeTxFee :: forall m . MonadAddresses m - => ProtocolMagic + => Core.Config -> PendingAddresses -> TxSizeLinear -> Utxo -> TxOutputs -> TxCreator m TxRaw -stabilizeTxFee pm pendingTx linearPolicy utxo outputs = do +stabilizeTxFee coreConfig pendingTx linearPolicy utxo outputs = do minFee <- fixedToFee (txSizeLinearMinValue linearPolicy) mtx <- stabilizeTxFeeDo (False, firstStageAttempts) minFee case mtx of @@ -807,9 +826,12 @@ 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 - txMinFee <- txToLinearFee linearPolicy $ - createFakeTxFromRawTx pm fakeChangeAddr txRaw + fakeChangeAddr <- lift . lift $ getFakeChangeAddress $ configEpochSlots + coreConfig + txMinFee <- txToLinearFee linearPolicy $ createFakeTxFromRawTx + (configProtocolMagic coreConfig) + fakeChangeAddr + txRaw let txRawWithFee = S.Min $ S.Arg expectedFee txRaw let iterateDo step = stabilizeTxFeeDo step txMinFee diff --git a/client/test/Test/Pos/Client/Txp/Mode.hs b/client/test/Test/Pos/Client/Txp/Mode.hs index 7833c2ab40e..44448ef69dc 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 691a2b64bf9..5d15ae70378 100644 --- a/client/test/Test/Pos/Client/Txp/UtilSpec.hs +++ b/client/test/Test/Pos/Client/Txp/UtilSpec.hs @@ -40,6 +40,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 (dummyConfig) import Test.Pos.Crypto.Arbitrary () import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Arbitrary (nonrepeating) @@ -117,8 +118,8 @@ testCreateMTx :: HasTxpConfigurations => CreateMTxParams -> TxpTestProperty (Either TxError (TxAux, NonEmpty TxOut)) -testCreateMTx CreateMTxParams{..} = lift $ - createMTx dummyProtocolMagic mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) +testCreateMTx CreateMTxParams {..} = lift $ + createMTx dummyConfig mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) cmpOutputs cmpAddrData createMTxWorksWhenWeAreRichSpec @@ -229,7 +230,7 @@ txWithRedeemOutputFailsSpec txWithRedeemOutputFailsSpec inputSelectionPolicy = do forAllM genParams $ \(CreateMTxParams {..}) -> do txOrError <- - createMTx dummyProtocolMagic mempty cmpInputSelectionPolicy cmpUtxo + createMTx dummyConfig mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) cmpOutputs cmpAddrData case txOrError of diff --git a/core/cardano-sl-core.cabal b/core/cardano-sl-core.cabal index c08a753fcbe..001864ca106 100644 --- a/core/cardano-sl-core.cabal +++ b/core/cardano-sl-core.cabal @@ -98,7 +98,6 @@ library Pos.Core.Configuration.Core Pos.Core.Configuration.GenesisData Pos.Core.Configuration.GenesisHash - Pos.Core.Configuration.Protocol -- Context Pos.Core.Context.PrimaryKey @@ -283,7 +282,6 @@ test-suite test Test.Pos.Core.Chrono Test.Pos.Core.ChronoSpec Test.Pos.Core.CoinSpec - Test.Pos.Core.EnumEmpTest Test.Pos.Core.ExampleHelpers Test.Pos.Core.Gen Test.Pos.Core.Json @@ -294,6 +292,7 @@ test-suite test Test.Pos.Core.Arbitrary Test.Pos.Core.Arbitrary.Slotting Test.Pos.Core.Arbitrary.Unsafe + Test.Pos.Core.Dummy build-depends: aeson , base diff --git a/core/src/Pos/Core/Configuration.hs b/core/src/Pos/Core/Configuration.hs index 9e3ba22caca..7c2498fc8b9 100644 --- a/core/src/Pos/Core/Configuration.hs +++ b/core/src/Pos/Core/Configuration.hs @@ -5,6 +5,13 @@ module Pos.Core.Configuration ( Config (..) + , configK + , configVssMinTTL + , configVssMaxTTL + , configBlkSecurityParam + , configSlotSecurityParam + , configChainQualityThreshold + , configEpochSlots , configGeneratedSecretsThrow , ConfigurationError (..) @@ -28,11 +35,11 @@ import System.IO.Error (userError) import qualified Text.JSON.Canonical as Canonical import Pos.Binary.Class (Raw) +import Pos.Core.Common (BlockCount) import Pos.Core.Configuration.BlockVersionData as E import Pos.Core.Configuration.Core 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 (GeneratedSecrets, GenesisData (..), GenesisDelegation, GenesisInitializer (..), GenesisProtocolConstants (..), GenesisSpec (..), @@ -40,17 +47,42 @@ import Pos.Core.Genesis (GeneratedSecrets, GenesisData (..), mkGenesisDelegation) import Pos.Core.Genesis.Generate (GeneratedGenesisData (..), generateGenesisData) -import Pos.Core.Slotting (Timestamp) +import Pos.Core.ProtocolConstants (ProtocolConstants (..), + pcBlkSecurityParam, pcChainQualityThreshold, pcEpochSlots, + pcSlotSecurityParam, vssMaxTTL, vssMinTTL) +import Pos.Core.Slotting (SlotCount, Timestamp) import Pos.Crypto.Configuration as E import Pos.Crypto.Hashing (Hash, hashRaw, unsafeHash) import Pos.Util.Json.Canonical (SchemaError) import Pos.Util.Util (leftToPanic) data Config = Config - { configProtocolMagic :: ProtocolMagic - , configGeneratedSecrets :: Maybe GeneratedSecrets + { configProtocolMagic :: ProtocolMagic + , configProtocolConstants :: ProtocolConstants + , configGeneratedSecrets :: Maybe GeneratedSecrets } +configK :: Config -> Int +configK = pcK . configProtocolConstants + +configVssMinTTL :: Integral i => Config -> i +configVssMinTTL = vssMinTTL . configProtocolConstants + +configVssMaxTTL :: Integral i => Config -> i +configVssMaxTTL = vssMaxTTL . configProtocolConstants + +configBlkSecurityParam :: Config -> BlockCount +configBlkSecurityParam = pcBlkSecurityParam . configProtocolConstants + +configSlotSecurityParam :: Config -> SlotCount +configSlotSecurityParam = pcSlotSecurityParam . configProtocolConstants + +configChainQualityThreshold :: Fractional f => Config -> f +configChainQualityThreshold = pcChainQualityThreshold . configProtocolConstants + +configEpochSlots :: Config -> SlotCount +configEpochSlots = pcEpochSlots . configProtocolConstants + configGeneratedSecretsThrow :: (HasCallStack, MonadIO m) => Config -> m GeneratedSecrets configGeneratedSecretsThrow = @@ -67,7 +99,6 @@ type HasConfiguration = , HasGenesisData , HasGenesisHash , HasGenesisBlockVersionData - , HasProtocolConstants ) canonicalGenesisJson :: GenesisData -> (BSL.ByteString, Hash Raw) @@ -139,14 +170,14 @@ withCoreConfigurations conf@CoreConfiguration{..} fn confDir mSystemStart mSeed (show theGenesisHash) (show expectedHash) withCoreConfiguration conf $ - withProtocolConstants pc $ withGenesisBlockVersionData (gdBlockVersionData theGenesisData) $ withGenesisData theGenesisData $ withGenesisHash theGenesisHash $ act $ Config - { configProtocolMagic = pm - , configGeneratedSecrets = Nothing + { configProtocolMagic = pm + , configProtocolConstants = pc + , configGeneratedSecrets = Nothing } -- If a 'GenesisSpec' is given, we ensure we have a start time (needed if @@ -181,12 +212,11 @@ withGenesisSpec withGenesisSpec theSystemStart conf@CoreConfiguration{..} fn 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 @@ -215,8 +245,9 @@ withGenesisSpec theSystemStart conf@CoreConfiguration{..} fn val = case ccGenesi withGenesisData theGenesisData $ val $ Config - { configProtocolMagic = pm - , configGeneratedSecrets = Just ggdSecrets + { configProtocolMagic = pm + , configProtocolConstants = pc + , configGeneratedSecrets = Just ggdSecrets } where pm = gpcProtocolMagic (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 fc78af91486..4e1cb104e75 100644 --- a/core/src/Pos/Core/Genesis/Generate.hs +++ b/core/src/Pos/Core/Genesis/Generate.hs @@ -35,9 +35,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, @@ -111,12 +111,12 @@ gsSecretKeysPoor :: GeneratedSecrets -> [SecretKey] gsSecretKeysPoor = map poorSecretToKey . gsPoorSecrets 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 @@ -172,7 +172,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 @@ -261,14 +261,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/JsonLog/LogEvents.hs b/core/src/Pos/Core/JsonLog/LogEvents.hs index 06bb7bfddcf..604e28a85f4 100644 --- a/core/src/Pos/Core/JsonLog/LogEvents.hs +++ b/core/src/Pos/Core/JsonLog/LogEvents.hs @@ -39,7 +39,7 @@ import Data.Aeson.Types (typeMismatch) import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HMS -import Pos.Core (EpochIndex (..), HasConfiguration, SlotId (..), +import Pos.Core (EpochIndex (..), SlotCount, SlotId (..), mkLocalSlotIndex) import Pos.Core.JsonLog.JsonLogT (JsonLogConfig (..)) import qualified Pos.Core.JsonLog.JsonLogT as JL @@ -176,12 +176,13 @@ $(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" diff --git a/core/src/Pos/Core/ProtocolConstants.hs b/core/src/Pos/Core/ProtocolConstants.hs index 83a186809e3..a076178420e 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 @@ -65,6 +74,14 @@ instance Aeson.ToJSON VssMaxTTL where instance Aeson.FromJSON VssMaxTTL where parseJSON = fmap VssMaxTTL . Aeson.parseJSON +-- | 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 @@ -73,7 +90,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 @@ -84,13 +104,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/Class.hs b/core/src/Pos/Core/Slotting/Class.hs index be283327a98..dac1f76b82d 100644 --- a/core/src/Pos/Core/Slotting/Class.hs +++ b/core/src/Pos/Core/Slotting/Class.hs @@ -15,6 +15,7 @@ import Universum import Control.Monad.Trans (MonadTrans) +import Pos.Core.Slotting.SlotCount (SlotCount) import Pos.Core.Slotting.SlotId (SlotId (..)) import Pos.Core.Slotting.Timestamp (Timestamp (..)) import Pos.Core.Slotting.Types (SlottingData) @@ -41,18 +42,18 @@ class HasSlottingVar ctx where -- | 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 @@ -61,7 +62,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/core/src/Pos/Core/Slotting/EpochOrSlot.hs b/core/src/Pos/Core/Slotting/EpochOrSlot.hs index 608474e3694..0ffbb481f45 100644 --- a/core/src/Pos/Core/Slotting/EpochOrSlot.hs +++ b/core/src/Pos/Core/Slotting/EpochOrSlot.hs @@ -27,14 +27,11 @@ module Pos.Core.Slotting.EpochOrSlot import Universum import Control.Lens (Getter, lens, to) -import Data.Bifunctor (bimap) import Data.SafeCopy (base, deriveSafeCopySimple) import qualified Formatting.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 @@ -74,47 +71,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 @@ -139,22 +164,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'. epochOrSlot :: (EpochIndex -> a) -> (SlotId -> a) -> EpochOrSlot -> a @@ -163,79 +189,8 @@ 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 - --- ----------------------------------------------------------------------------- --- EpochOrSLot used to have an 'Enum' instance, but the pending removal of --- 'HasProtocolConstants' means that is no longer possible. - -epochOrSlotToEnum :: SlotCount -> Int -> EpochOrSlot -epochOrSlotToEnum es x = - let (epoch, slot) = - bimap fromIntegral fromIntegral $ x `divMod` (fromIntegral es + 1) - slotIdx = - leftToPanic "epochOrSlotToEnum:" $ mkLocalSlotIndexExplicit es (slot - 1) - in - if | x < 0 -> error "epochOrSlotToEnum: Negative argument" - | slot == 0 -> EpochOrSlot (Left epoch) - | otherwise -> - EpochOrSlot $ Right (SlotId epoch slotIdx) - -epochOrSlotFromEnum :: SlotCount -> EpochOrSlot -> Int -epochOrSlotFromEnum es (EpochOrSlot eos) = case eos of - Left e -> - let res = toInteger e * toInteger (es + 1) - maxIntAsInteger = toInteger (maxBound :: Int) - in if | res > maxIntAsInteger -> - error "epochOrSlotFromEnum: Argument larger than 'maxBound :: Int'" - | otherwise -> fromIntegral res - Right SlotId {..} -> - let res = toInteger (epochOrSlotFromEnum es (EpochOrSlot (Left siEpoch))) + - toInteger (getSlotIndex siSlot) + - 1 - maxIntAsInteger = toInteger (maxBound :: Int) - in if | res > maxIntAsInteger -> - error "epochOrSlotFromEnum: Argument larger than 'maxBound :: Int'" - | otherwise -> fromIntegral res - -epochOrSlotSucc :: SlotCount -> EpochOrSlot -> EpochOrSlot -epochOrSlotSucc es e@(EpochOrSlot eos) = case eos of - Left ep -> EpochOrSlot - (Right SlotId {siEpoch = ep, siSlot = localSlotIndexMinBound}) - Right si@SlotId {..} - | e == epochOrSlotMaxBound es -> - error "succ@EpochOrSlot: maxBound" - | siSlot == localSlotIndexMaxBoundExplicit es -> - EpochOrSlot $ Left (siEpoch + 1) - | otherwise -> - EpochOrSlot $ Right si { siSlot = localSlotIndexSucc es siSlot } - -epochOrSlotPred :: SlotCount -> EpochOrSlot -> EpochOrSlot -epochOrSlotPred es e@(EpochOrSlot eos) = case eos of - Left ep - | e == epochOrSlotMinBound -> - error "epochOrSlotPred: minBound" - | otherwise -> - EpochOrSlot $ Right (SlotId (ep - 1) (localSlotIndexMaxBoundExplicit es)) - Right si@SlotId {..} - | siSlot == localSlotIndexMinBound -> EpochOrSlot (Left siEpoch) - | otherwise -> EpochOrSlot $ Right si { siSlot = localSlotIndexPred es siSlot } - -epochOrSlotEnumFromTo - :: SlotCount -> EpochOrSlot -> EpochOrSlot -> [EpochOrSlot] -epochOrSlotEnumFromTo es x y = fmap - (epochOrSlotToEnum es) - [epochOrSlotFromEnum es x .. epochOrSlotFromEnum es y] - -epochOrSlotMinBound :: EpochOrSlot -epochOrSlotMinBound = EpochOrSlot (Left (EpochIndex 0)) - -epochOrSlotMaxBound :: SlotCount -> EpochOrSlot -epochOrSlotMaxBound es = EpochOrSlot $ Right SlotId - { siSlot = localSlotIndexMaxBoundExplicit es - , siEpoch = maxBound - } +epochOrSlotToSlot :: EpochOrSlot -> SlotId +epochOrSlotToSlot = epochOrSlot (flip SlotId localSlotIndexMinBound) identity -- ----------------------------------------------------------------------------- -- TH derived instances at the end of the file. diff --git a/core/src/Pos/Core/Slotting/LocalSlotIndex.hs b/core/src/Pos/Core/Slotting/LocalSlotIndex.hs index c2255e1f7fe..9a9b7027104 100644 --- a/core/src/Pos/Core/Slotting/LocalSlotIndex.hs +++ b/core/src/Pos/Core/Slotting/LocalSlotIndex.hs @@ -2,8 +2,6 @@ module Pos.Core.Slotting.LocalSlotIndex ( LocalSlotIndex (..) , mkLocalSlotIndex - , mkLocalSlotIndexExplicit - , mkLocalSlotIndexThrow_ , addLocalSlotIndex , localSlotIndexToEnum @@ -16,7 +14,7 @@ module Pos.Core.Slotting.LocalSlotIndex , localSlotIndexMaxBoundExplicit , localSlotIndices - , unsafeMkLocalSlotIndexExplicit + , unsafeMkLocalSlotIndex ) where import Universum @@ -28,9 +26,6 @@ import Data.SafeCopy (base, deriveSafeCopySimple) import System.Random (Random (..)) import Pos.Binary.Class (Bi (..)) -import Pos.Core.Configuration.Protocol (HasProtocolConstants, - epochSlots) -import Pos.Core.ProtocolConstants (ProtocolConstants, pcEpochSlots) import Pos.Util.Util (leftToPanic) import Pos.Core.Slotting.SlotCount (SlotCount) @@ -40,22 +35,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 @@ -63,8 +66,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) localSlotIndexMaxBoundExplicit :: SlotCount -> LocalSlotIndex localSlotIndexMaxBoundExplicit es = UnsafeLocalSlotIndex (fromIntegral es - 1) @@ -81,55 +85,29 @@ 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 => SlotCount -> Word16 -> m LocalSlotIndex -mkLocalSlotIndexExplicit es = mkLocalSlotIndexThrow_ es + 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 -unsafeMkLocalSlotIndexExplicit :: SlotCount -> Word16 -> LocalSlotIndex -unsafeMkLocalSlotIndexExplicit es = - leftToPanic "unsafeMkLocalSlotIndex failed: " . mkLocalSlotIndexExplicit es - --- ----------------------------------------------------------------------------- --- LocalSlotIndex used to have an 'Enum' instance, but the pending removal of --- 'HasProtocolConstants' means that is no longer possible. Instead we use --- functions. - -localSlotIndexToEnum :: SlotCount -> Int -> LocalSlotIndex -localSlotIndexToEnum es i - | i >= fromIntegral es = error - "localSlotIndexToEnum: greater than maxBound" - | i < 0 = error "localSlotIndexToEnum: less than minBound" - | otherwise = UnsafeLocalSlotIndex (fromIntegral i) - -localSlotIndexFromEnum :: LocalSlotIndex -> Int -localSlotIndexFromEnum = fromIntegral . getSlotIndex - -localSlotIndexSucc :: SlotCount -> LocalSlotIndex -> LocalSlotIndex -localSlotIndexSucc es = - localSlotIndexToEnum es . (+ 1) . localSlotIndexFromEnum - -localSlotIndexPred :: SlotCount -> LocalSlotIndex -> LocalSlotIndex -localSlotIndexPred es = - localSlotIndexToEnum es . subtract 1 . localSlotIndexFromEnum +-- | Unsafe constructor of 'LocalSlotIndex'. +unsafeMkLocalSlotIndex :: SlotCount -> Word16 -> LocalSlotIndex +unsafeMkLocalSlotIndex epochSlots = + leftToPanic "unsafeMkLocalSlotIndex failed: " . mkLocalSlotIndex epochSlots -- ----------------------------------------------------------------------------- -- TH derived instances at the end of the file. diff --git a/core/src/Pos/Core/Slotting/SlotId.hs b/core/src/Pos/Core/Slotting/SlotId.hs index 985f4f62cba..fd21dd380c3 100644 --- a/core/src/Pos/Core/Slotting/SlotId.hs +++ b/core/src/Pos/Core/Slotting/SlotId.hs @@ -15,10 +15,8 @@ module Pos.Core.Slotting.SlotId , flatSlotId , flattenSlotId - , flattenSlotIdExplicit , flattenEpochIndex , unflattenSlotId - , unflattenSlotIdExplicit , crucialSlot ) where @@ -34,8 +32,8 @@ import Formatting (Format, bprint, build, later, (%)) import qualified Formatting.Buildable as Buildable 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 @@ -82,23 +80,19 @@ flip makeLensesFor ''SlotId [ ("siEpoch", "siEpochL"), ("siSlot" , "siSlotL") ] -instance HasProtocolConstants => Enum SlotId where - toEnum = unflattenSlotId . fromIntegral - fromEnum = fromIntegral . flattenSlotId - slotIdToEnum :: SlotCount -> Int -> SlotId -slotIdToEnum es = unflattenSlotIdExplicit es . fromIntegral +slotIdToEnum epochSlots = unflattenSlotId epochSlots . fromIntegral slotIdFromEnum :: SlotCount -> SlotId -> Int -slotIdFromEnum es = fromIntegral . flattenSlotIdExplicit es +slotIdFromEnum epochSlots = fromIntegral . flattenSlotId epochSlots slotIdSucc :: SlotCount -> SlotId -> SlotId -slotIdSucc es = - slotIdToEnum es . (+ 1) . slotIdFromEnum es +slotIdSucc epochSlots = + slotIdToEnum epochSlots . (+ 1) . slotIdFromEnum epochSlots slotIdPred :: SlotCount -> SlotId -> SlotId -slotIdPred es = - slotIdToEnum es . subtract 1 . slotIdFromEnum es +slotIdPred epochSlots = + slotIdToEnum epochSlots . subtract 1 . slotIdFromEnum epochSlots instance HasEpochIndex SlotId where epochIndexL = lens siEpoch (\s a -> s {siEpoch = a}) @@ -111,44 +105,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 "unflattenSlotIdExplicit: " $ 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/src/Pos/Core/Slotting/Util.hs b/core/src/Pos/Core/Slotting/Util.hs index dcaedc45996..728f5f272ef 100644 --- a/core/src/Pos/Core/Slotting/Util.hs +++ b/core/src/Pos/Core/Slotting/Util.hs @@ -21,14 +21,13 @@ import Universum import Data.Time.Units (Microsecond, convertUnit) -import Pos.Core.Configuration.Protocol (HasProtocolConstants, - epochSlots) import Pos.Core.Slotting.Class (MonadSlots (..), MonadSlotsData) import Pos.Core.Slotting.EpochIndex (EpochIndex (..)) import Pos.Core.Slotting.LocalSlotIndex (LocalSlotIndex (..), mkLocalSlotIndex) import Pos.Core.Slotting.MemState (getSystemStartM, withSlottingVarAtomM) +import Pos.Core.Slotting.SlotCount (SlotCount) import Pos.Core.Slotting.SlotId (FlatSlotId, SlotId (..), flattenSlotId) import Pos.Core.Slotting.TimeDiff (addTimeDiffToTimestamp) @@ -41,8 +40,9 @@ import Pos.Util.Util (leftToPanic) -- | 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 -- | Parameters for `onNewSlot`. @@ -91,10 +91,11 @@ data ActionTerminationPolicy -- | 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 @@ -168,7 +169,7 @@ slotFromTimestamp approxCurTime = do localSlot :: LocalSlotIndex localSlot = leftToPanic "computeSlotUsingEpoch: " $ - mkLocalSlotIndex localSlotNumeric + mkLocalSlotIndex epochSlots localSlotNumeric slotDuration :: Microsecond slotDuration = convertUnit esdSlotDuration diff --git a/core/test/Test/Pos/Core/Arbitrary.hs b/core/test/Test/Pos/Core/Arbitrary.hs index efdc0a0f440..834cf73aa1b 100644 --- a/core/test/Test/Pos/Core/Arbitrary.hs +++ b/core/test/Test/Pos/Core/Arbitrary.hs @@ -52,14 +52,13 @@ import Pos.Core (AddrAttributes (..), AddrSpendingData (..), mkMultiKeyDistr, unsafeCoinPortionFromDouble, unsafeGetCoin, unsafeSubCoin) import Pos.Core.Attributes (Attributes (..), UnparsedFields (..)) -import Pos.Core.Configuration (HasGenesisBlockVersionData, - HasProtocolConstants, epochSlots, protocolConstants) +import Pos.Core.Configuration (HasGenesisBlockVersionData) import Pos.Core.Constants (sharedSeedLength) import Pos.Core.Delegation (HeavyDlgIndex (..), LightDlgIndices (..)) import qualified Pos.Core.Genesis as G import Pos.Core.Merkle (MerkleTree, mkMerkleTree) import Pos.Core.ProtocolConstants (ProtocolConstants (..), - VssMaxTTL (..), VssMinTTL (..)) + VssMaxTTL (..), VssMinTTL (..), pcEpochSlots) import Pos.Core.Ssc (VssCertificate, mkVssCertificate, mkVssCertificatesMapLossy) import Pos.Core.Update (ApplicationName (..), BlockVersion (..), @@ -68,6 +67,7 @@ import Pos.Core.Update (ApplicationName (..), BlockVersion (..), import Pos.Crypto (ProtocolMagic, createPsk, toPublic) 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 () @@ -122,24 +122,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 @@ -152,16 +152,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 <$> @@ -179,8 +180,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 @@ -562,7 +564,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 e7d8ab434d1..2b5275b6a24 100644 --- a/core/test/Test/Pos/Core/Arbitrary/Unsafe.hs +++ b/core/test/Test/Pos/Core/Arbitrary/Unsafe.hs @@ -12,7 +12,6 @@ import Pos.Core (AddrAttributes (..), AddrStakeDistribution (..), AddrType (..), Address (..), Coin, EpochIndex (..), LocalSlotIndex, SharedSeed (..), SlotId (..), mkCoin) import Pos.Core.Attributes (mkAttributes) -import Pos.Core.Configuration (HasProtocolConstants) import Test.Pos.Core.Arbitrary () import Test.Pos.Crypto.Arbitrary () @@ -21,7 +20,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 @@ -38,5 +37,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 00c3318f5e3..8fe507a58b6 100644 --- a/core/test/Test/Pos/Core/Bi.hs +++ b/core/test/Test/Pos/Core/Bi.hs @@ -66,7 +66,7 @@ import Test.Pos.Core.ExampleHelpers (exampleAddrSpendingData_PubKey, exampleUpdateProposal, exampleUpdateProposalToSign, exampleUpdateVote, exampleVoteId, exampleVssCertificate, exampleVssCertificatesHash, exampleVssCertificatesMap, - feedPC, feedPM, staticHeavyDlgIndexes, + feedEpochSlots, feedPM, staticHeavyDlgIndexes, staticProxySKHeavys) import Test.Pos.Core.Gen import Test.Pos.Crypto.Bi (getBytes) @@ -389,7 +389,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 @@ -409,7 +409,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 @@ -428,7 +428,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 diff --git a/core/test/Test/Pos/Core/Dummy.hs b/core/test/Test/Pos/Core/Dummy.hs index 51920c605d0..f0edb1396f6 100644 --- a/core/test/Test/Pos/Core/Dummy.hs +++ b/core/test/Test/Pos/Core/Dummy.hs @@ -1,7 +1,11 @@ {-# LANGUAGE NumDecimals #-} module Test.Pos.Core.Dummy - ( dummyProtocolConstants + ( dummyConfig + , dummyProtocolConstants + , dummyK + , dummyEpochSlots + , dummySlotSecurityParam , dummyGenesisInitializer , dummyGenesisAvvmBalances , dummyGeneratedGenesisData @@ -15,9 +19,10 @@ module Test.Pos.Core.Dummy import Universum -import Pos.Core (ProtocolConstants (..), VssMaxTTL (..), - VssMinTTL (..), unsafeCoinPortionFromDouble, - withProtocolConstants) +import Pos.Core (BlockCount, Config (..), ProtocolConstants (..), + SlotCount, VssMaxTTL (..), VssMinTTL (..), kEpochSlots, + kSlotSecurityParam, pcBlkSecurityParam, + unsafeCoinPortionFromDouble) import Pos.Core.Genesis (FakeAvvmOptions (..), GeneratedGenesisData (..), GeneratedSecrets (..), GenesisAvvmBalances (..), GenesisInitializer (..), @@ -28,6 +33,13 @@ import Pos.Crypto (SecretKey) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +dummyConfig :: Config +dummyConfig = Config + { configProtocolMagic = dummyProtocolMagic + , configProtocolConstants = dummyProtocolConstants + , configGeneratedSecrets = Just dummyGeneratedSecrets + } + dummyProtocolConstants :: ProtocolConstants dummyProtocolConstants = ProtocolConstants { pcK = 10 @@ -35,12 +47,20 @@ dummyProtocolConstants = ProtocolConstants , pcVssMaxTTL = VssMaxTTL 6 } +dummyK :: BlockCount +dummyK = pcBlkSecurityParam dummyProtocolConstants + +dummyEpochSlots :: SlotCount +dummyEpochSlots = kEpochSlots dummyK + +dummySlotSecurityParam :: SlotCount +dummySlotSecurityParam = kSlotSecurityParam dummyK + dummyGeneratedGenesisData :: GeneratedGenesisData -dummyGeneratedGenesisData = - withProtocolConstants dummyProtocolConstants $ generateGenesisData - dummyProtocolMagic - dummyGenesisInitializer - dummyGenesisAvvmBalances +dummyGeneratedGenesisData = generateGenesisData dummyProtocolMagic + dummyProtocolConstants + dummyGenesisInitializer + dummyGenesisAvvmBalances dummyGeneratedSecrets :: GeneratedSecrets dummyGeneratedSecrets = ggdSecrets dummyGeneratedGenesisData diff --git a/core/test/Test/Pos/Core/EnumEmpTest.hs b/core/test/Test/Pos/Core/EnumEmpTest.hs deleted file mode 100644 index 7e0335b750e..00000000000 --- a/core/test/Test/Pos/Core/EnumEmpTest.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -module Test.Pos.Core.EnumEmpTest - ( tests - ) where - --- The types `EpochOrSlot`, `LocalSlotIndex` and `SlotId` have a --- `HasProtocoConstants` constraint as well as `Enum` instances which depend --- on the `HasProtocoConstants` constraint. Since we want to remove --- `HasProtocoConstants` the first step is to provide functions that will act --- like the `Enum` methods, but take an extra parameter for --- the part they require from `ProtocolConstants`. - --- These tests to show the equivalence between the 'Enum/HasProtocolConstant' --- instances for these types and the new functions that replace them. When the --- 'Enum/HasProtocolConstant' are removed, these tests will also be removed. - -import Control.DeepSeq (force) -import Control.Exception (ErrorCall (..)) -import qualified Control.Exception as Exception -import Control.Monad.IO.Class (liftIO) -import Universum - -import Hedgehog (Property, PropertyT, discover, (===)) -import qualified Hedgehog as H -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range - -import Pos.Core (pcEpochSlots, withProtocolConstants) -import Pos.Core.Slotting (epochOrSlotFromEnum, epochOrSlotToEnum, - localSlotIndexFromEnum, localSlotIndexToEnum, - slotIdFromEnum, slotIdToEnum) - -import Test.Pos.Core.Gen - - -prop_enum_eqivanent_epochOrSlotFromEnum :: Property -prop_enum_eqivanent_epochOrSlotFromEnum = - H.withTests 5000 . H.property $ do - pc <- H.forAll genProtocolConstants - eos <- H.forAll $ genEpochOrSlot pc - old <- catchErrorCall $ withProtocolConstants pc (fromEnum eos) - new <- catchErrorCall $ epochOrSlotFromEnum (pcEpochSlots pc) eos - old === new - -prop_enum_eqivanent_epochOrSlotToEnum :: Property -prop_enum_eqivanent_epochOrSlotToEnum = - H.withTests 5000 . H.property $ do - i <- H.forAll $ Gen.int (Range.linear (-10) 10000) - pc <- H.forAll genProtocolConstants - old <- catchErrorCall $ withProtocolConstants pc (toEnum i) - new <- catchErrorCall $ epochOrSlotToEnum (pcEpochSlots pc) i - old === new - -prop_enum_eqivanent_localSlotIndexFromEnum :: Property -prop_enum_eqivanent_localSlotIndexFromEnum = - H.withTests 5000 . H.property $ do - pc <- H.forAll genProtocolConstants - lsi <- H.forAll $ genLocalSlotIndex pc - old <- catchErrorCall $ withProtocolConstants pc (fromEnum lsi) - new <- catchErrorCall $ localSlotIndexFromEnum lsi - old === new - -prop_enum_eqivanent_localSlotIndexToEnum :: Property -prop_enum_eqivanent_localSlotIndexToEnum = - H.withTests 5000 . H.property $ do - i <- H.forAll $ Gen.int (Range.linear (-10) 1000000000) - pc <- H.forAll genProtocolConstants - old <- catchErrorCall $ withProtocolConstants pc (toEnum i) - new <- catchErrorCall $ localSlotIndexToEnum (pcEpochSlots pc) i - old === new - -prop_enum_eqivanent_slotIdFromEnum :: Property -prop_enum_eqivanent_slotIdFromEnum = - H.withTests 5000 . H.property $ do - pc <- H.forAll genProtocolConstants - sid <- H.forAll $ genSlotId pc - old <- catchErrorCall $ withProtocolConstants pc (fromEnum sid) - new <- catchErrorCall $ slotIdFromEnum (pcEpochSlots pc) sid - old === new - -prop_enum_eqivanent_slotIdToEnum :: Property -prop_enum_eqivanent_slotIdToEnum = - H.withTests 5000 . H.property $ do - i <- H.forAll $ Gen.int (Range.linear (-10) 1000000) - pc <- H.forAll genProtocolConstants - old <- catchErrorCall $ withProtocolConstants pc (toEnum i) - new <- catchErrorCall $ slotIdToEnum (pcEpochSlots pc) i - old === new - --- | Evaluate and force a pure value and if the evaluation of the pure value --- causes 'error' to be called, catch 'ErrorCall' and return the error message --- with the "functionName:" part removed. --- --- This is the stupid level of crap you have to go through when people --- think its ok to sprinkle 'error' and 'MonadError' throughout otherwise --- pure code. -catchErrorCall :: NFData a => a -> PropertyT IO (Either String a) -catchErrorCall = - fmap convert . liftIO . Exception.try . Exception.evaluate . force - where - convert :: Either ErrorCall a -> Either String a - convert (Left (ErrorCallWithLocation s _)) = Left $ drop 1 (dropWhile (/= ':') s) - convert (Right x) = Right x - -tests :: IO Bool -tests = - H.checkParallel $$discover diff --git a/core/test/Test/Pos/Core/ExampleHelpers.hs b/core/test/Test/Pos/Core/ExampleHelpers.hs index 76aa33a6900..0a60b8fac5e 100644 --- a/core/test/Test/Pos/Core/ExampleHelpers.hs +++ b/core/test/Test/Pos/Core/ExampleHelpers.hs @@ -76,6 +76,8 @@ module Test.Pos.Core.ExampleHelpers , feedPM , feedPC , feedPMC + , feedEpochSlots + , feedPMEpochSlots ) where import Universum @@ -115,9 +117,9 @@ import Pos.Core.Genesis (FakeAvvmOptions (..), GenesisSpec (..), TestnetBalanceOptions (..)) import Pos.Core.Merkle (mkMerkleTree, mtRoot) import Pos.Core.ProtocolConstants (ProtocolConstants, VssMaxTTL (..), - VssMinTTL (..)) + VssMinTTL (..), pcEpochSlots) import Pos.Core.Slotting (EpochIndex (..), FlatSlotId, - LocalSlotIndex (..), SlotId (..)) + LocalSlotIndex (..), SlotCount, SlotId (..)) import Pos.Core.Ssc (Commitment, CommitmentSignature, CommitmentsMap, InnerSharesMap, Opening, OpeningsMap, SharesDistribution, SignedCommitment, SscPayload (..), SscProof (..), @@ -167,6 +169,14 @@ feedPMC genA = do pc <- genProtocolConstants genA pm pc +feedEpochSlots :: (SlotCount -> H.Gen a) -> H.Gen a +feedEpochSlots genA = genA =<< pcEpochSlots <$> genProtocolConstants + +feedPMEpochSlots :: (ProtocolMagic -> SlotCount -> H.Gen a) -> H.Gen a +feedPMEpochSlots genA = do + pm <- genProtocolMagic + epochSlots <- pcEpochSlots <$> genProtocolConstants + genA pm epochSlots -------------------------------------------------------------------------------- -- Example golden datatypes diff --git a/core/test/Test/Pos/Core/Gen.hs b/core/test/Test/Pos/Core/Gen.hs index 95ccefd93e2..ef530c5bf12 100644 --- a/core/test/Test/Pos/Core/Gen.hs +++ b/core/test/Test/Pos/Core/Gen.hs @@ -494,26 +494,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 8bfbcbf1fe0..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 id $ \_ -> 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 id $ \_ -> 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/test.hs b/core/test/test.hs index 96edb3f6815..f7ae48c74f1 100644 --- a/core/test/test.hs +++ b/core/test/test.hs @@ -5,7 +5,6 @@ import Test.Hspec (hspec) import Spec (spec) import qualified Test.Pos.Core.Bi -import qualified Test.Pos.Core.EnumEmpTest import qualified Test.Pos.Core.Json import Test.Pos.Util.Tripping (runTests) @@ -14,6 +13,5 @@ main = do hspec spec runTests [ Test.Pos.Core.Bi.tests - , Test.Pos.Core.EnumEmpTest.tests , Test.Pos.Core.Json.tests ] diff --git a/db/Makefile b/db/Makefile new file mode 100644 index 00000000000..380de55db71 --- /dev/null +++ b/db/Makefile @@ -0,0 +1,13 @@ +help: ## Print documentation + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +ghcid: ## Run ghcid with the cardano-sl-db package + ghcid \ + --command "stack ghci cardano-sl-db --ghci-options=-fno-code" + +ghcid-test: ## Have ghcid run the test suite for the wallet-new-specs on successful recompile + ghcid \ + --command "stack ghci cardano-sl-db:lib cardano-sl-db:test:test --ghci-options=-fobject-code" \ + --test "Main.main" + +.PHONY: ghcid ghcid-test help diff --git a/db/src/Pos/DB/Block/BListener.hs b/db/src/Pos/DB/Block/BListener.hs index d271b0554d4..9b8dce187e9 100644 --- a/db/src/Pos/DB/Block/BListener.hs +++ b/db/src/Pos/DB/Block/BListener.hs @@ -15,6 +15,7 @@ import Universum import Control.Monad.Trans (MonadTrans (..)) import Pos.Chain.Block (Blund) +import Pos.Core (ProtocolConstants) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.DB.BatchOp (SomeBatchOp) @@ -25,14 +26,14 @@ 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)) => MonadBListener (t m) where onApplyBlocks = lift . onApplyBlocks - onRollbackBlocks = lift . onRollbackBlocks + onRollbackBlocks pc = lift . onRollbackBlocks pc onApplyBlocksStub :: Monad m diff --git a/db/src/Pos/DB/Block/GState/BlockExtra.hs b/db/src/Pos/DB/Block/GState/BlockExtra.hs index 7c618b60ad5..3f8e085edfa 100644 --- a/db/src/Pos/DB/Block/GState/BlockExtra.hs +++ b/db/src/Pos/DB/Block/GState/BlockExtra.hs @@ -10,6 +10,7 @@ module Pos.DB.Block.GState.BlockExtra , getLastSlots , getFirstGenesisBlockHash , BlockExtraOp (..) + , buildBlockExtraOp , foldlUpWhileM , loadHashesUpWhile , loadHeadersUpWhile @@ -22,16 +23,14 @@ import Universum hiding (init) import Data.Conduit (ConduitT, yield) import qualified Database.RocksDB as Rocks -import Formatting (bprint, build, (%)) -import qualified Formatting.Buildable +import Formatting (Format, bprint, build, later, (%)) import Serokell.Util.Text (listJson) import Pos.Binary.Class (serialize') import Pos.Chain.Block (Block, BlockHeader, HasHeaderHash, HeaderHash, LastBlkSlots, headerHash, noLastBlkSlots) -import Pos.Core (FlatSlotId, HasCoreConfiguration, - HasProtocolConstants, genesisHash, slotIdF, - unflattenSlotId) +import Pos.Core (FlatSlotId, HasCoreConfiguration, SlotCount, + genesisHash, slotIdF, unflattenSlotId) import Pos.Core.Chrono (OldestFirst (..)) import Pos.Crypto (shortHashF) import Pos.DB (DBError (..), MonadDB, MonadDBRead (..), @@ -87,16 +86,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/db/src/Pos/DB/Block/Logic/Creation.hs b/db/src/Pos/DB/Block/Logic/Creation.hs index af464516d01..5819ae7aaf1 100644 --- a/db/src/Pos/DB/Block/Logic/Creation.hs +++ b/db/src/Pos/DB/Block/Logic/Creation.hs @@ -33,9 +33,11 @@ import Pos.Chain.Ssc (MonadSscMem, defaultSscPayload, stripSscPayload) import Pos.Chain.Txp (TxpConfiguration, emptyTxPayload) import Pos.Chain.Update (HasUpdateConfiguration, curSoftwareVersion, lastKnownBlockVersion) -import Pos.Core (EpochIndex, EpochOrSlot (..), HasProtocolConstants, - SlotId (..), chainQualityThreshold, epochIndexL, - epochSlots, flattenSlotId, getEpochOrSlot) +import Pos.Core as Core (BlockCount, Config (..), EpochIndex, + EpochOrSlot (..), SlotId (..), configBlkSecurityParam, + configEpochSlots, epochIndexL, flattenSlotId, + getEpochOrSlot, kChainQualityThreshold, kEpochSlots, + localSlotIndexMinBound) import Pos.Core.Context (HasPrimaryKey, getOurSecretKey) import Pos.Core.Exception (assertionFailed, reportFatalError) import Pos.Core.JsonLog (CanJsonLog (..)) @@ -46,7 +48,7 @@ import Pos.Core.Ssc (SscPayload) import Pos.Core.Txp (TxAux (..), mkTxPayload) import Pos.Core.Update (UpdatePayload (..)) import Pos.Core.Util.LogSafe (logInfoS) -import Pos.Crypto (ProtocolMagic, SecretKey) +import Pos.Crypto (SecretKey) import Pos.DB.Block.Logic.Internal (MonadBlockApply, applyBlocksUnsafe, normalizeMempool) import Pos.DB.Block.Logic.Util (calcChainQualityM) @@ -117,57 +119,66 @@ createGenesisBlockAndApply :: , HasLens (StateLockMetrics MemPoolModifyReason) ctx (StateLockMetrics MemPoolModifyReason) , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> EpochIndex -> m (Maybe GenesisBlock) -- Genesis block for 0-th epoch is hardcoded. createGenesisBlockAndApply _ _ 0 = pure Nothing -createGenesisBlockAndApply pm txpConfig epoch = do +createGenesisBlockAndApply coreConfig txpConfig epoch = do tipHeader <- DB.getTipHeader -- preliminary check outside the lock, -- must be repeated inside the lock - needGen <- needCreateGenesisBlock epoch tipHeader + needGen <- needCreateGenesisBlock (configBlkSecurityParam coreConfig) + epoch + tipHeader if needGen then modifyStateLock HighPriority ApplyBlock - (\_ -> createGenesisBlockDo pm txpConfig epoch) + (\_ -> createGenesisBlockDo coreConfig txpConfig epoch) else return Nothing createGenesisBlockDo :: forall ctx m. - ( MonadCreateBlock ctx m - , HasMisbehaviorMetrics ctx - ) - => ProtocolMagic + (MonadCreateBlock ctx m, HasMisbehaviorMetrics ctx) + => Core.Config -> TxpConfiguration -> EpochIndex -> m (HeaderHash, Maybe GenesisBlock) -createGenesisBlockDo pm txpConfig epoch = do +createGenesisBlockDo coreConfig txpConfig epoch = do tipHeader <- DB.getTipHeader logDebug $ sformat msgTryingFmt epoch tipHeader - needCreateGenesisBlock epoch tipHeader >>= \case - False -> (BC.blockHeaderHash tipHeader, Nothing) <$ logShouldNot - True -> actuallyCreate tipHeader + needCreateGenesisBlock (configBlkSecurityParam coreConfig) epoch tipHeader + >>= \case + False -> + (BC.blockHeaderHash tipHeader, Nothing) <$ logShouldNot + True -> actuallyCreate tipHeader where -- We need to run LRC here to make 'verifyBlocksPrefix' not hang. -- It's important to do it after taking 'StateLock'. -- Note that it shouldn't fail, because 'shouldCreate' guarantees that we -- have enough blocks for LRC. actuallyCreate tipHeader = do - lrcSingleShot pm epoch + lrcSingleShot coreConfig epoch leaders <- lrcActionOnEpochReason epoch "createGenesisBlockDo " LrcDB.getLeadersForEpoch - let blk = mkGenesisBlock pm (Right tipHeader) epoch leaders + let blk = mkGenesisBlock (configProtocolMagic coreConfig) + (Right tipHeader) + epoch + leaders let newTip = headerHash blk - curSlot <- getCurrentSlot - verifyBlocksPrefix pm curSlot (one (Left blk)) >>= \case + curSlot <- getCurrentSlot $ configEpochSlots coreConfig + verifyBlocksPrefix coreConfig curSlot (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 txpConfig + applyBlocksUnsafe + coreConfig + (ShouldCallBListener True) + (one (Left blk, undo)) + (Just pollModifier) + normalizeMempool coreConfig txpConfig pure (newTip, Just blk) logShouldNot = logDebug @@ -176,13 +187,13 @@ createGenesisBlockDo pm txpConfig 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 -- This is true iff tip is from 'epoch' - 1 and last @@ -191,12 +202,12 @@ needCreateGenesisBlock epoch tipHeader = do BlockHeaderMain mb -> if mb ^. epochIndexL /= epoch - 1 then pure False - else calcChainQualityM (flattenSlotId $ SlotId epoch minBound) <&> \case + 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 -> chainQualityThreshold @Double <= cq + Just cq -> kChainQualityThreshold @Double k <= cq ---------------------------------------------------------------------------- -- MainBlock @@ -220,18 +231,18 @@ createMainBlockAndApply :: , HasLens' ctx StateLock , HasLens' ctx (StateLockMetrics MemPoolModifyReason) ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> SlotId -> ProxySKBlockInfo -> m (Either Text MainBlock) -createMainBlockAndApply pm txpConfig sId pske = +createMainBlockAndApply coreConfig txpConfig sId pske = modifyStateLock HighPriority ApplyBlock createAndApply where createAndApply tip = - createMainBlockInternal pm sId pske >>= \case + createMainBlockInternal coreConfig sId pske >>= \case Left reason -> pure (tip, Left reason) - Right blk -> convertRes <$> applyCreatedBlock pm txpConfig pske blk + Right blk -> convertRes <$> applyCreatedBlock coreConfig txpConfig pske blk convertRes createdBlk = (headerHash createdBlk, Right createdBlk) ---------------------------------------------------------------------------- @@ -247,36 +258,38 @@ createMainBlockInternal :: forall ctx m. ( MonadCreateBlock ctx m ) - => ProtocolMagic + => Core.Config -> SlotId -> ProxySKBlockInfo -> m (Either Text MainBlock) -createMainBlockInternal pm sId pske = do +createMainBlockInternal coreConfig 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 + k = configBlkSecurityParam coreConfig 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 getMaxBlockSize - block <- createMainBlockPure pm sizeLimit prevHeader pske sId sk rawPay + block <- createMainBlockPure coreConfig sizeLimit prevHeader pske sId sk rawPay logInfoS $ "Created main block of size: " <> sformat memory (biSize block) block <$ evaluateNF_ block canCreateBlock :: MonadCreateBlock ctx m - => SlotId + => 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 +297,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) @@ -307,8 +320,8 @@ canCreateBlock sId tipHeader = createMainBlockPure :: forall m. - ( MonadError Text m, HasUpdateConfiguration, HasProtocolConstants ) - => ProtocolMagic + (MonadError Text m, HasUpdateConfiguration) + => Core.Config -> Byte -- ^ Block size limit (real max.value) -> BlockHeader -> ProxySKBlockInfo @@ -316,14 +329,16 @@ createMainBlockPure -> SecretKey -> RawPayload -> m MainBlock -createMainBlockPure pm limit prevHeader pske sId sk rawPayload = do +createMainBlockPure coreConfig 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 + k = configBlkSecurityParam coreConfig + pm = configProtocolMagic coreConfig -- 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; @@ -348,38 +363,37 @@ createMainBlockPure pm limit prevHeader pske sId sk rawPayload = do -- 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 - ) - => ProtocolMagic + forall ctx m. + (MonadBlockApply ctx m, MonadCreateBlock ctx m) + => Core.Config -> TxpConfiguration -> ProxySKBlockInfo -> MainBlock -> m MainBlock -applyCreatedBlock pm txpConfig pske createdBlock = applyCreatedBlockDo False createdBlock +applyCreatedBlock coreConfig txpConfig pske createdBlock = applyCreatedBlockDo False createdBlock where + epochSlots = configEpochSlots coreConfig slotId = createdBlock ^. BC.mainBlockSlot applyCreatedBlockDo :: Bool -> MainBlock -> m MainBlock applyCreatedBlockDo isFallback blockToApply = do - curSlot <- getCurrentSlot - verifyBlocksPrefix pm curSlot (one (Right blockToApply)) >>= \case + curSlot <- getCurrentSlot epochSlots + verifyBlocksPrefix coreConfig curSlot (one (Right blockToApply)) >>= \case Left (pretty -> reason) | isFallback -> onFailedFallback reason | otherwise -> fallback reason Right (undos, pollModifier) -> do let undo = undos ^. _Wrapped . _neHead applyBlocksUnsafe - pm + coreConfig (ShouldCallBListener True) (one (Right blockToApply, undo)) (Just pollModifier) - normalizeMempool pm txpConfig + normalizeMempool coreConfig txpConfig pure blockToApply clearMempools :: m () clearMempools = do withTxpLocalData clearTxpMemPool - sscResetLocal + sscResetLocal epochSlots clearUSMemPool clearDlgMemPool fallback :: Text -> m MainBlock @@ -390,7 +404,7 @@ applyCreatedBlock pm txpConfig pske createdBlock = applyCreatedBlockDo False cre logDebug $ "Clearing mempools" clearMempools logDebug $ "Creating empty block" - createMainBlockInternal pm slotId pske >>= \case + createMainBlockInternal coreConfig slotId pske >>= \case Left err -> assertionFailed $ sformat ("Couldn't create a block in fallback: "%stext) err @@ -412,12 +426,13 @@ data RawPayload = RawPayload } getRawPayload :: MonadCreateBlock ctx m - => HeaderHash + => 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 = @@ -436,15 +451,16 @@ 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 + 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) @@ -457,7 +473,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/db/src/Pos/DB/Block/Logic/Header.hs b/db/src/Pos/DB/Block/Logic/Header.hs index f0a52a12932..8d0fcd4df4d 100644 --- a/db/src/Pos/DB/Block/Logic/Header.hs +++ b/db/src/Pos/DB/Block/Logic/Header.hs @@ -30,13 +30,12 @@ import UnliftIO (MonadUnliftIO) import Pos.Chain.Block (BlockHeader (..), HeaderHash, VerifyHeaderParams (..), headerHash, headerHashG, headerSlotL, prevBlockL, verifyHeader) -import Pos.Core (blkSecurityParam, difficultyL, epochIndexL, - getEpochOrSlot) +import Pos.Core as Core (BlockCount, Config (..), configEpochSlots, + difficultyL, epochIndexL, getEpochOrSlot) import Pos.Core.Chrono (NE, NewestFirst, OldestFirst (..), toNewestFirst, toOldestFirst, _NewestFirst, _OldestFirst) import Pos.Core.Slotting (MonadSlots (getCurrentSlot)) import Pos.Core.Update (bvdMaxHeaderSize) -import Pos.Crypto.Configuration (ProtocolMagic) import Pos.DB (MonadDBRead) import qualified Pos.DB.Block.GState.BlockExtra as GS import Pos.DB.Block.Load (loadHeadersByDepth) @@ -76,11 +75,11 @@ classifyNewHeader , MonadDBRead m , MonadUnliftIO m ) - => ProtocolMagic -> BlockHeader -> m ClassifyHeaderRes + => Core.Config -> 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 coreConfig (BlockHeaderMain header) = fmap (either identity identity) <$> runExceptT $ do + curSlot <- getCurrentSlot $ configEpochSlots coreConfig tipHeader <- lift DB.getTipHeader let tipEoS = getEpochOrSlot tipHeader let newHeaderEoS = getEpochOrSlot header @@ -122,6 +121,7 @@ classifyNewHeader pm (BlockHeaderMain header) = fmap (either identity identity) , vhpMaxSize = Just maxBlockHeaderSize , vhpVerifyNoUnknown = False } + let pm = configProtocolMagic coreConfig case verifyHeader pm vhp (BlockHeaderMain header) of VerFailure errors -> throwError $ mkCHRinvalid (NE.toList errors) _ -> pass @@ -214,8 +214,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. @@ -223,7 +225,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. - loadHeadersByDepth (blkSecurityParam + 1) upToReal + loadHeadersByDepth (k + 1) upToReal let toNE = fromMaybe (error "getHeadersOlderExp: couldn't create nonempty") . nonEmpty let selectedHashes :: NewestFirst [] HeaderHash diff --git a/db/src/Pos/DB/Block/Logic/Internal.hs b/db/src/Pos/DB/Block/Logic/Internal.hs index 29ccfcb92e9..7935876e6cf 100644 --- a/db/src/Pos/DB/Block/Logic/Internal.hs +++ b/db/src/Pos/DB/Block/Logic/Internal.hs @@ -42,11 +42,11 @@ import Pos.Chain.Delegation (DlgBlock, DlgBlund, MonadDelegation) import Pos.Chain.Ssc (HasSscConfiguration, MonadSscMem, SscBlock) import Pos.Chain.Txp (TxpConfiguration) import Pos.Chain.Update (PollModifier) -import Pos.Core (epochIndexL) +import Pos.Core as Core (Config (..), configBlkSecurityParam, + configEpochSlots, epochIndexL) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Exception (assertionFailed) import Pos.Core.Reporting (MonadReporting) -import Pos.Crypto (ProtocolMagic) import Pos.DB (MonadDB, MonadDBRead, MonadGState, SomeBatchOp (..)) import Pos.DB.Block.BListener (MonadBListener) import Pos.DB.Block.GState.SanityCheck (sanityCheckDB) @@ -124,15 +124,15 @@ type MonadMempoolNormalization ctx m -- | Normalize mempool. normalizeMempool :: MonadMempoolNormalization ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> m () -normalizeMempool pm txpConfig = do +normalizeMempool coreConfig txpConfig = 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 txpConfig + sscNormalize coreConfig + txpNormalize coreConfig txpConfig usNormalize -- | Applies a definitely valid prefix of blocks. This function is unsafe, @@ -143,12 +143,12 @@ normalizeMempool pm txpConfig = do applyBlocksUnsafe :: ( MonadBlockApply ctx m ) - => ProtocolMagic + => Core.Config -> ShouldCallBListener -> OldestFirst NE Blund -> Maybe PollModifier -> m () -applyBlocksUnsafe pm scb blunds pModifier = do +applyBlocksUnsafe coreConfig 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"% @@ -168,7 +168,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 coreConfig scb x pModifier app' = app . OldestFirst (thisEpoch, nextEpoch) = spanSafe ((==) `on` view (_1 . epochIndexL)) $ getOldestFirst blunds @@ -176,23 +176,23 @@ applyBlocksUnsafe pm scb blunds pModifier = do applyBlocksDbUnsafeDo :: ( MonadBlockApply ctx m ) - => ProtocolMagic + => Core.Config -> ShouldCallBListener -> OldestFirst NE Blund -> Maybe PollModifier -> m () -applyBlocksDbUnsafeDo pm scb blunds pModifier = do +applyBlocksDbUnsafeDo coreConfig 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 (configBlkSecurityParam coreConfig) scb blunds TxpGlobalSettings {..} <- view (lensOf @TxpGlobalSettings) - usBatch <- SomeBatchOp <$> usApplyBlocks pm (map toUpdateBlock blocks) pModifier + usBatch <- SomeBatchOp <$> usApplyBlocks coreConfig (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 + sscApplyBlocks coreConfig (map toSscBlock blocks) Nothing GS.writeBatchGState [ delegateBatch , usBatch @@ -206,20 +206,23 @@ applyBlocksDbUnsafeDo pm scb blunds pModifier = do -- current tip. It's also assumed that lock on block db is taken already. rollbackBlocksUnsafe :: MonadBlockApply ctx m - => ProtocolMagic + => Core.Config -> 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 +rollbackBlocksUnsafe coreConfig bsc scb toRollback = do + slogRoll <- slogRollbackBlocks (configProtocolConstants coreConfig) + 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 + sscBatch <- SomeBatchOp <$> sscRollbackBlocks (configEpochSlots coreConfig) (map (toSscBlock . fst) toRollback) GS.writeBatchGState [ dlgRoll @@ -233,7 +236,7 @@ rollbackBlocksUnsafe pm bsc scb toRollback = do -- We don't normalize other mempools, because they are normalized -- in 'applyBlocksUnsafe' and we always ensure that some blocks -- are applied after rollback. - dlgNormalizeOnRollback pm + dlgNormalizeOnRollback $ configProtocolMagic coreConfig sanityCheckDB diff --git a/db/src/Pos/DB/Block/Logic/Types.hs b/db/src/Pos/DB/Block/Logic/Types.hs new file mode 100644 index 00000000000..a4c721e6143 --- /dev/null +++ b/db/src/Pos/DB/Block/Logic/Types.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE RecordWildCards #-} + +module Pos.DB.Block.Logic.Types + ( VerifyBlocksContext (..) + , getVerifyBlocksContext + , getVerifyBlocksContext' + ) where + +import Universum + +import Pos.Core.Slotting (MonadSlots (getCurrentSlot), SlotCount, + SlotId) +import Pos.Core.Update (BlockVersion, BlockVersionData) +import Pos.DB.Class (MonadDBRead) +import Pos.DB.Update (getAdoptedBVFull) + +-- | Initial context for `verifyBlocksPrefix` which runs in `MonadBlockVerify` +-- monad. +data VerifyBlocksContext = VerifyBlocksContext + { vbcCurrentSlot :: !(Maybe SlotId) + -- ^ used to check if headers are not from future + , vbcBlockVersion :: !BlockVersion + , vbcBlockVersionData :: !BlockVersionData + } deriving Generic + +instance NFData VerifyBlocksContext + +getVerifyBlocksContext + :: forall ctx m. + ( MonadDBRead m + , MonadSlots ctx m + ) + => SlotCount + -> m VerifyBlocksContext +getVerifyBlocksContext epochSlots = + getCurrentSlot epochSlots >>= getVerifyBlocksContext' + +getVerifyBlocksContext' + :: MonadDBRead m + => Maybe SlotId + -> m VerifyBlocksContext +getVerifyBlocksContext' vbcCurrentSlot = do + (vbcBlockVersion, vbcBlockVersionData) <- getAdoptedBVFull + return $ VerifyBlocksContext {..} diff --git a/db/src/Pos/DB/Block/Logic/Util.hs b/db/src/Pos/DB/Block/Logic/Util.hs index 328380716c0..2ca2084ed82 100644 --- a/db/src/Pos/DB/Block/Logic/Util.hs +++ b/db/src/Pos/DB/Block/Logic/Util.hs @@ -26,10 +26,9 @@ import Formatting (int, sformat, (%)) import Pos.Chain.Block (BlockHeader, HasBlockConfiguration, HasSlogGState, HeaderHash, fixedTimeCQ, headerHash, prevBlockL) -import Pos.Core (BlockCount, FlatSlotId, HasProtocolConstants, - Timestamp (..), difficultyL, flattenSlotId) +import Pos.Core (BlockCount, FlatSlotId, SlotCount, Timestamp (..), + difficultyL, flattenSlotId) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) -import Pos.Core.Configuration (blkSecurityParam) import Pos.Core.Exception (reportFatalError) import Pos.Core.Slotting (MonadSlots (..), getCurrentSlotFlat, slotFromTimestamp) @@ -99,24 +98,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 @@ -130,12 +129,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 @@ -157,20 +157,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/db/src/Pos/DB/Block/Logic/VAR.hs b/db/src/Pos/DB/Block/Logic/VAR.hs index 0ff4d348dfe..989a5b2a760 100644 --- a/db/src/Pos/DB/Block/Logic/VAR.hs +++ b/db/src/Pos/DB/Block/Logic/VAR.hs @@ -29,12 +29,11 @@ import Pos.Chain.Block (ApplyBlocksException (..), Block, Blund, VerifyBlocksException (..), headerHashG, prevBlockL) import Pos.Chain.Txp (TxpConfiguration) import Pos.Chain.Update (PollModifier) -import Pos.Core (epochIndexL) +import Pos.Core as Core (Config (..), configEpochSlots, epochIndexL) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst, toOldestFirst) import Pos.Core.Reporting (HasMisbehaviorMetrics) import Pos.Core.Slotting (MonadSlots (getCurrentSlot), SlotId) -import Pos.Crypto (ProtocolMagic) import Pos.DB.Block.Logic.Internal (BypassSecurityCheck (..), MonadBlockApply, MonadBlockVerify, MonadMempoolNormalization, applyBlocksUnsafe, @@ -75,11 +74,11 @@ verifyBlocksPrefix :: forall ctx m. ( MonadBlockVerify ctx m ) - => ProtocolMagic + => Core.Config -> Maybe SlotId -- ^ current slot to verify that headers are not from future slots -> OldestFirst NE Block -> m (Either VerifyBlocksException (OldestFirst NE Undo, PollModifier)) -verifyBlocksPrefix pm currentSlot blocks = runExceptT $ do +verifyBlocksPrefix coreConfig currentSlot blocks = runExceptT $ do -- This check (about tip) is here just in case, we actually check -- it before calling this function. tip <- lift GS.getTip @@ -95,15 +94,16 @@ verifyBlocksPrefix pm currentSlot blocks = runExceptT $ do -- the internal consistency checks formerly done in the 'Bi' instance -- 'decode'. slogUndos <- withExceptT VerifyBlocksError $ - ExceptT $ slogVerifyBlocks pm currentSlot blocks + ExceptT $ slogVerifyBlocks coreConfig currentSlot blocks _ <- withExceptT (VerifyBlocksError . pretty) $ - ExceptT $ sscVerifyBlocks pm (map toSscBlock blocks) + ExceptT $ sscVerifyBlocks coreConfig (map toSscBlock blocks) TxpGlobalSettings {..} <- view (lensOf @TxpGlobalSettings) txUndo <- withExceptT (VerifyBlocksError . pretty) $ ExceptT $ tgsVerifyBlocks dataMustBeKnown $ map toTxpBlock blocks - pskUndo <- withExceptT VerifyBlocksError $ dlgVerifyBlocks pm blocks + pskUndo <- withExceptT VerifyBlocksError + $ dlgVerifyBlocks (configProtocolMagic coreConfig) blocks (pModifier, usUndos) <- withExceptT (VerifyBlocksError . pretty) $ - ExceptT $ usVerifyBlocks pm dataMustBeKnown (map toUpdateBlock blocks) + ExceptT $ usVerifyBlocks coreConfig dataMustBeKnown (map toUpdateBlock blocks) -- Eventually we do a sanity check just in case and return the result. when (length txUndo /= length pskUndo) $ @@ -135,19 +135,19 @@ verifyAndApplyBlocks , MonadMempoolNormalization ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> Maybe SlotId -> Bool -> OldestFirst NE Block -> m (Either ApplyBlocksException (HeaderHash, NewestFirst [] Blund)) -verifyAndApplyBlocks pm txpConfig curSlot rollback blocks = runExceptT $ do +verifyAndApplyBlocks coreConfig txpConfig curSlot 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 txpConfig + lift $ normalizeMempool coreConfig txpConfig pure hh where -- Spans input into @(a, b)@ where @a@ is either a single genesis @@ -176,11 +176,15 @@ verifyAndApplyBlocks pm txpConfig curSlot rollback blocks = runExceptT $ do applyAMAP e (OldestFirst []) _ True = throwError e applyAMAP _ (OldestFirst []) blunds False = (,blunds) <$> lift GS.getTip applyAMAP e (OldestFirst (block:xs)) blunds nothingApplied = do - lift (verifyBlocksPrefix pm curSlot (one block)) >>= \case + lift (verifyBlocksPrefix coreConfig curSlot (one block)) >>= \case Left (ApplyBlocksVerifyFailure -> e') -> applyAMAP e' (OldestFirst []) blunds nothingApplied Right (OldestFirst (undo :| []), pModifier) -> do - lift $ applyBlocksUnsafe pm (ShouldCallBListener True) (one (block, undo)) (Just pModifier) + lift $ applyBlocksUnsafe + coreConfig + (ShouldCallBListener True) + (one (block, undo)) + (Just pModifier) applyAMAP e (OldestFirst xs) (NewestFirst $ (block, undo) : getNewestFirst blunds) False Right _ -> error "verifyAndApplyBlocksInternal: applyAMAP: \ \verification of one block produced more than one undo" @@ -191,7 +195,7 @@ verifyAndApplyBlocks pm txpConfig curSlot rollback blocks = runExceptT $ do -> ExceptT ApplyBlocksException m (HeaderHash, NewestFirst [] Blund) failWithRollback e toRollback = do logDebug "verifyAndapply failed, rolling back" - lift $ mapM_ (rollbackBlocks pm) toRollback + lift $ mapM_ (rollbackBlocks coreConfig) 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 @@ -209,9 +213,9 @@ verifyAndApplyBlocks pm txpConfig curSlot rollback blocks = runExceptT $ do let epochIndex = prefixHead ^. epochIndexL logDebug $ "Rolling: Calculating LRC if needed for epoch " <> pretty epochIndex - lift $ lrcSingleShot pm epochIndex + lift $ lrcSingleShot coreConfig epochIndex logDebug "Rolling: verifying" - lift (verifyBlocksPrefix pm curSlot prefix) >>= \case + lift (verifyBlocksPrefix coreConfig curSlot prefix) >>= \case Left (ApplyBlocksVerifyFailure -> failure) | rollback -> failWithRollback failure blunds | otherwise -> do @@ -226,7 +230,11 @@ verifyAndApplyBlocks pm txpConfig curSlot rollback blocks = runExceptT $ do getOldestFirst undos let blunds' = toNewestFirst newBlunds : blunds logDebug "Rolling: Verification done, applying unsafe block" - lift $ applyBlocksUnsafe pm (ShouldCallBListener True) newBlunds (Just pModifier) + lift $ applyBlocksUnsafe + coreConfig + (ShouldCallBListener True) + newBlunds + (Just pModifier) case getOldestFirst suffix of [] -> (,concatNE blunds') <$> lift GS.getTip (genesis:xs) -> do @@ -247,21 +255,21 @@ applyBlocks . ( BlockLrcMode ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> Bool -> Maybe PollModifier -> OldestFirst NE Blund -> m () -applyBlocks pm calculateLrc pModifier blunds = do +applyBlocks coreConfig 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 coreConfig (prefixHead ^. epochIndexL) + applyBlocksUnsafe coreConfig (ShouldCallBListener True) prefix pModifier case getOldestFirst suffix of [] -> pass - (genesis:xs) -> applyBlocks pm calculateLrc pModifier (OldestFirst (genesis:|xs)) + (genesis:xs) -> applyBlocks coreConfig calculateLrc pModifier (OldestFirst (genesis:|xs)) where prefixHead = prefix ^. _Wrapped . _neHead . _1 (prefix, suffix) = spanEpoch blunds @@ -275,13 +283,16 @@ 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 + => Core.Config + -> NewestFirst NE Blund + -> m () +rollbackBlocks coreConfig 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 coreConfig (BypassSecurityCheck False) (ShouldCallBListener True) blunds -- | Rollbacks some blocks and then applies some blocks. applyWithRollback @@ -290,18 +301,18 @@ applyWithRollback , MonadMempoolNormalization ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> NewestFirst NE Blund -- ^ Blocks to rollbck -> OldestFirst NE Block -- ^ Blocks to apply -> m (Either ApplyBlocksException HeaderHash) -applyWithRollback pm txpConfig toRollback toApply = runExceptT $ do +applyWithRollback coreConfig txpConfig toRollback toApply = runExceptT $ do tip <- lift GS.getTip when (tip /= newestToRollback) $ throwError $ ApplyBlocksTipMismatch "applyWithRollback/rollback" tip newestToRollback let doRollback = rollbackBlocksUnsafe - pm + coreConfig (BypassSecurityCheck False) (ShouldCallBListener True) toRollback @@ -315,7 +326,7 @@ applyWithRollback pm txpConfig toRollback toApply = runExceptT $ do where reApply = toOldestFirst toRollback applyBack :: m () - applyBack = applyBlocks pm False Nothing reApply + applyBack = applyBlocks coreConfig False Nothing reApply expectedTipApply = toApply ^. _Wrapped . _neHead . prevBlockL newestToRollback = toRollback ^. _Wrapped . _neHead . _1 . headerHashG @@ -323,7 +334,7 @@ applyWithRollback pm txpConfig toRollback toApply = runExceptT $ do applyBack $> Left (ApplyBlocksTipMismatch "applyWithRollback/apply" tip newestToRollback) onGoodRollback = do - curSlot <- getCurrentSlot - verifyAndApplyBlocks pm txpConfig curSlot True toApply >>= \case + curSlot <- getCurrentSlot $ configEpochSlots coreConfig + verifyAndApplyBlocks coreConfig txpConfig curSlot True toApply >>= \case Left err -> applyBack $> Left err Right (tipHash, _) -> pure (Right tipHash) diff --git a/db/src/Pos/DB/Block/Lrc.hs b/db/src/Pos/DB/Block/Lrc.hs index 3299893f974..96decc49015 100644 --- a/db/src/Pos/DB/Block/Lrc.hs +++ b/db/src/Pos/DB/Block/Lrc.hs @@ -28,16 +28,16 @@ import Pos.Chain.Lrc (LrcError (..), RichmenStakes, followTheSatoshiM) import Pos.Chain.Ssc (MonadSscMem, noReportNoSecretsForEpoch1) import Pos.Chain.Update (BlockVersionState (..)) -import Pos.Core (Coin, EpochIndex, EpochOrSlot (..), SharedSeed, - StakeholderId, blkSecurityParam, crucialSlot, epochIndexL, - epochSlots, getEpochOrSlot) +import Pos.Core as Core (Coin, Config, EpochIndex, EpochOrSlot (..), + SharedSeed, SlotCount, StakeholderId, + configBlkSecurityParam, configEpochSlots, configK, + crucialSlot, epochIndexL, getEpochOrSlot) import Pos.Core.Chrono (NE, NewestFirst (..), toOldestFirst) import Pos.Core.Conc (forConcurrently) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), MisbehaviorMetrics (..)) import Pos.Core.Slotting (MonadSlots) import Pos.Core.Util.TimeLimit (logWarningWaitLinear) -import Pos.Crypto (ProtocolMagic) import qualified Pos.DB.Block.GState.SanityCheck as DB (sanityCheckDB) import qualified Pos.DB.Block.Load as DB import Pos.DB.Block.Logic.Internal (BypassSecurityCheck (..), @@ -77,10 +77,10 @@ type LrcModeFull ctx m = lrcSingleShot :: forall ctx m . (LrcModeFull ctx m, HasMisbehaviorMetrics ctx) - => ProtocolMagic + => Core.Config -> EpochIndex -> m () -lrcSingleShot pm epoch = do +lrcSingleShot coreConfig epoch = do lock <- views (lensOf @LrcContext) lcLrcSync logDebug $ sformat ("lrcSingleShot is trying to acquire LRC lock, the epoch is " @@ -106,7 +106,7 @@ lrcSingleShot pm epoch = do , expectedRichmenComp) when need $ do logInfo "LRC is starting actual computation" - lrcDo pm epoch filteredConsumers + lrcDo coreConfig epoch filteredConsumers logInfo "LRC has finished actual computation" putEpoch epoch logInfo ("LRC has updated LRC DB" <> for_thEpochMsg) @@ -134,11 +134,11 @@ lrcDo . ( LrcModeFull ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> EpochIndex -> [LrcConsumer m] -> m () -lrcDo pm epoch consumers = do +lrcDo coreConfig 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. @@ -172,18 +172,20 @@ lrcDo pm epoch consumers = do issuersComputationDo epoch richmenComputationDo epoch consumers DB.sanityCheckDB - leadersComputationDo epoch seed + leadersComputationDo (configEpochSlots coreConfig) epoch seed where atLeastKNewestFirst :: forall a. NewestFirst [] a -> Maybe (NewestFirst NE a) atLeastKNewestFirst l = - if length l >= fromIntegral blkSecurityParam + if length l >= configK coreConfig then coerce (nonEmpty @a) l else Nothing - applyBack blunds = applyBlocksUnsafe pm scb blunds Nothing + applyBack blunds = applyBlocksUnsafe coreConfig scb blunds Nothing upToGenesis b = b ^. epochIndexL >= epoch whileAfterCrucial b = getEpochOrSlot b > crucial - crucial = EpochOrSlot $ Right $ crucialSlot epoch + crucial = EpochOrSlot $ Right $ crucialSlot + (configBlkSecurityParam coreConfig) + 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' @@ -195,7 +197,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 coreConfig bsc scb blunds) (applyBack (toOldestFirst blunds)) issuersComputationDo :: forall ctx m . LrcMode ctx m => EpochIndex -> m () @@ -214,15 +216,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/db/src/Pos/DB/Block/Slog/Context.hs b/db/src/Pos/DB/Block/Slog/Context.hs index f41916d0dbf..f69d8ddbbf2 100644 --- a/db/src/Pos/DB/Block/Slog/Context.hs +++ b/db/src/Pos/DB/Block/Slog/Context.hs @@ -18,7 +18,7 @@ import qualified System.Metrics as Ekg import Pos.Chain.Block (HasBlockConfiguration, HasSlogGState (..), LastBlkSlots, SlogContext (..), SlogGState (..), fixedTimeCQSec, sgsLastBlkSlots) -import Pos.Core (blkSecurityParam) +import Pos.Core (BlockCount) import Pos.Core.Metrics.Constants (withCardanoNamespace) import Pos.Core.Reporting (MetricMonitorState, mkMetricMonitorState) import Pos.DB.Block.GState.BlockExtra (getLastSlots) @@ -31,19 +31,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/db/src/Pos/DB/Block/Slog/Logic.hs b/db/src/Pos/DB/Block/Slog/Logic.hs index e399a06c8a6..02ddce6d18e 100644 --- a/db/src/Pos/DB/Block/Slog/Logic.hs +++ b/db/src/Pos/DB/Block/Slog/Logic.hs @@ -36,14 +36,15 @@ import Pos.Chain.Block (Block, Blund, HasSlogGState, SlogUndo (..), mainBlockSlot, prevBlockL, verifyBlocks) import Pos.Chain.Update (HasUpdateConfiguration, lastKnownBlockVersion) -import Pos.Core (FlatSlotId, blkSecurityParam, difficultyL, - epochIndexL, flattenSlotId) +import Pos.Core as Core (BlockCount, Config (..), FlatSlotId, + ProtocolConstants, configEpochSlots, configK, difficultyL, + epochIndexL, flattenSlotId, kEpochSlots, + pcBlkSecurityParam) import Pos.Core.Chrono (NE, NewestFirst (getNewestFirst), OldestFirst (..), toOldestFirst, _OldestFirst) import Pos.Core.Exception (assertionFailed, reportFatalError) import Pos.Core.Slotting (MonadSlots, SlotId) import Pos.Core.Update (BlockVersion (..)) -import Pos.Crypto (ProtocolMagic) import Pos.DB (SomeBatchOp (..)) import Pos.DB.Block.BListener (MonadBListener (..)) import qualified Pos.DB.Block.GState.BlockExtra as GS @@ -128,11 +129,11 @@ type MonadSlogVerify ctx m = -- 3. Compute 'SlogUndo's and return them. slogVerifyBlocks :: MonadSlogVerify ctx m - => ProtocolMagic + => Core.Config -> Maybe SlotId -- ^ current slot -> OldestFirst NE Block -> m (Either Text (OldestFirst NE SlogUndo)) -slogVerifyBlocks pm curSlot blocks = runExceptT $ do +slogVerifyBlocks coreConfig curSlot blocks = runExceptT $ do (adoptedBV, adoptedBVD) <- lift getAdoptedBVFull let dataMustBeKnown = mustDataBeKnown adoptedBV let headEpoch = blocks ^. _Wrapped . _neHead . epochIndexL @@ -155,12 +156,19 @@ slogVerifyBlocks pm curSlot blocks = runExceptT $ do let blocksList :: OldestFirst [] Block blocksList = OldestFirst (NE.toList (getOldestFirst blocks)) verResToMonadError formatAllErrors $ - verifyBlocks pm curSlot dataMustBeKnown adoptedBVD leaders blocksList + verifyBlocks + coreConfig + 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 (configEpochSlots coreConfig) . 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 +178,7 @@ slogVerifyBlocks pm curSlot blocks = runExceptT $ do let removedSlots :: OldestFirst [] FlatSlotId removedSlots = combinedSlots & _Wrapped %~ - (take $ length combinedSlots - fromIntegral blkSecurityParam) + (take $ length combinedSlots - configK coreConfig) -- 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 +223,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 +261,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 +269,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 +292,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 +312,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/db/src/Pos/DB/Lrc/Leaders.hs b/db/src/Pos/DB/Lrc/Leaders.hs index 8ec2b04a943..9de8954af9b 100644 --- a/db/src/Pos/DB/Lrc/Leaders.hs +++ b/db/src/Pos/DB/Lrc/Leaders.hs @@ -20,10 +20,8 @@ import Universum import Pos.Binary.Class (serialize') import Pos.Chain.Lrc (genesisLeaders) -import Pos.Core (EpochIndex, HasProtocolConstants, SlotCount, - SlotId (SlotId), SlotLeaders, StakeholderId, - flattenSlotId, pcEpochSlots, protocolConstants, - unsafeMkLocalSlotIndexExplicit) +import Pos.Core (EpochIndex, SlotCount, SlotId (SlotId), SlotLeaders, + StakeholderId, flattenSlotId, unsafeMkLocalSlotIndex) import Pos.DB.Class (MonadDB, MonadDBRead) import Pos.DB.Lrc.Common (dbHasKey, getBi, putBatch, putBatchBi, putBi, toRocksOps) @@ -35,8 +33,8 @@ import Pos.DB.Lrc.Common (dbHasKey, getBi, putBatch, putBatchBi, 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 @@ -46,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 ---------------------------------------------------------------------------- @@ -64,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. @@ -76,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 () @@ -93,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/" @@ -114,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 @unsafeMkLocalSlotIndexExplicit@ because we trust the callers. - SlotId epoch' (unsafeMkLocalSlotIndexExplicit (pcEpochSlots protocolConstants) slot) + -- Using @unsafeMkLocalSlotIndex@ because we trust the callers. + SlotId epoch' (unsafeMkLocalSlotIndex epochSlots slot) diff --git a/db/src/Pos/DB/Ssc/Logic/Local.hs b/db/src/Pos/DB/Ssc/Logic/Local.hs index a3b3fd2177b..251bbe137f8 100644 --- a/db/src/Pos/DB/Ssc/Logic/Local.hs +++ b/db/src/Pos/DB/Ssc/Logic/Local.hs @@ -41,14 +41,15 @@ import Pos.Chain.Ssc (HasSscConfiguration, MonadSscMem, PureToss, supplyPureTossEnv, syncingStateWith, tmCertificates, tmCommitments, tmOpenings, tmShares, verifyAndApplySscPayload) -import Pos.Core (EpochIndex, HasGenesisData, HasProtocolConstants, - SlotId (..), StakeholderId, epochIndexL) +import Pos.Core as Core (BlockCount, Config, EpochIndex, + HasGenesisData, SlotId (..), StakeholderId, + configBlkSecurityParam, configEpochSlots, epochIndexL, + kEpochSlots) import Pos.Core.Slotting (MonadSlots (getCurrentSlot)) import Pos.Core.Ssc (InnerSharesMap, Opening, SignedCommitment, SscPayload (..), VssCertificate, mkCommitmentsMap, mkVssCertificatesMapSingleton) import Pos.Core.Update (BlockVersionData (..)) -import Pos.Crypto (ProtocolMagic) import Pos.DB (MonadBlockDBRead, MonadDBRead, MonadGState (gsAdoptedBVData)) import Pos.DB.BlockIndex (getTipHeader) @@ -60,14 +61,13 @@ import Pos.Util.Wlog (WithLogger, launchNamedPureLog, logWarning) -- empty payload can be returned. sscGetLocalPayload :: forall ctx m. - (MonadIO m, MonadSscMem ctx m, WithLogger m, HasProtocolConstants) - => SlotId -> m SscPayload -sscGetLocalPayload = sscRunLocalQuery . sscGetLocalPayloadQ + (MonadIO m, MonadSscMem ctx m, WithLogger m) + => BlockCount -> SlotId -> m SscPayload +sscGetLocalPayload k = sscRunLocalQuery . sscGetLocalPayloadQ k sscGetLocalPayloadQ - :: (HasProtocolConstants) - => SlotId -> SscLocalQuery SscPayload -sscGetLocalPayloadQ SlotId {..} = do + :: BlockCount -> SlotId -> SscLocalQuery SscPayload +sscGetLocalPayloadQ k SlotId {..} = do expectedEpoch <- view ldEpoch let warningMsg = sformat warningFmt siEpoch expectedEpoch isExpected <- @@ -79,9 +79,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 @@ -91,8 +91,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 @@ -100,8 +100,9 @@ sscNormalize , MonadIO m , Rand.MonadRandom m ) - => ProtocolMagic -> m () -sscNormalize pm = do + => Core.Config + -> m () +sscNormalize coreConfig = do tipEpoch <- view epochIndexL <$> getTipHeader richmenData <- getSscRichmen "sscNormalize" tipEpoch bvd <- gsAdoptedBVData @@ -113,24 +114,24 @@ sscNormalize pm = do launchNamedPureLog atomically $ syncingStateWith localVar $ executeMonadBaseRandom seed $ - sscNormalizeU pm (tipEpoch, richmenData) bvd gs + sscNormalizeU coreConfig (tipEpoch, richmenData) bvd gs where -- (... MonadPseudoRandom) a -> (... n) a executeMonadBaseRandom seed = hoist $ hoist (pure . fst . Rand.withDRG seed) sscNormalizeU - :: (HasProtocolConstants, HasGenesisData) - => ProtocolMagic + :: HasGenesisData + => Core.Config -> (EpochIndex, RichmenStakes) -> BlockVersionData -> SscGlobalState -> SscLocalUpdate () -sscNormalizeU pm (epoch, stake) bvd gs = do +sscNormalizeU coreConfig (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 coreConfig epoch oldModifier ldModifier .= newModifier ldEpoch .= epoch ldSize .= biSize newModifier @@ -147,12 +148,11 @@ 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 tag k . siSlot) <$> getCurrentSlot (kEpochSlots k)) (evalTossInMem $ sscIsDataUsefulDo tag) (pure False) where @@ -192,54 +192,54 @@ type SscDataProcessingMode ctx m = -- current state (global + local) and adding to local state if it's valid. sscProcessCommitment :: SscDataProcessingMode ctx m - => ProtocolMagic + => Core.Config -> SignedCommitment -> m (Either SscVerifyError ()) -sscProcessCommitment pm comm = - sscProcessData pm CommitmentMsg +sscProcessCommitment coreConfig comm = + sscProcessData coreConfig CommitmentMsg $ CommitmentsPayload (mkCommitmentsMap [comm]) mempty -- | Process 'Opening' received from network, checking it against -- current state (global + local) and adding to local state if it's valid. sscProcessOpening :: SscDataProcessingMode ctx m - => ProtocolMagic + => Core.Config -> StakeholderId -> Opening -> m (Either SscVerifyError ()) -sscProcessOpening pm id opening = sscProcessData pm OpeningMsg +sscProcessOpening coreConfig id opening = sscProcessData coreConfig OpeningMsg $ OpeningsPayload (HM.fromList [(id, opening)]) mempty -- | Process 'InnerSharesMap' received from network, checking it against -- current state (global + local) and adding to local state if it's valid. sscProcessShares :: SscDataProcessingMode ctx m - => ProtocolMagic + => Core.Config -> StakeholderId -> InnerSharesMap -> m (Either SscVerifyError ()) -sscProcessShares pm id shares = - sscProcessData pm SharesMsg $ SharesPayload (HM.fromList [(id, shares)]) mempty +sscProcessShares coreConfig id shares = + sscProcessData coreConfig 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 + => Core.Config -> VssCertificate -> m (Either SscVerifyError ()) -sscProcessCertificate pm cert = sscProcessData pm VssCertificateMsg +sscProcessCertificate coreConfig cert = sscProcessData coreConfig VssCertificateMsg $ CertificatesPayload (mkVssCertificatesMapSingleton cert) sscProcessData :: SscDataProcessingMode ctx m - => ProtocolMagic + => Core.Config -> SscTag -> SscPayload -> m (Either SscVerifyError ()) -sscProcessData pm tag payload = +sscProcessData coreConfig tag payload = runExceptT $ do - getCurrentSlot >>= checkSlot + getCurrentSlot (configEpochSlots coreConfig) >>= checkSlot ld <- sscRunLocalQuery ask bvd <- gsAdoptedBVData let epoch = ld ^. ldEpoch @@ -251,11 +251,11 @@ sscProcessData pm tag payload = ExceptT $ sscRunLocalSTM $ executeMonadBaseRandom seed $ - sscProcessDataDo pm (epoch, richmen) bvd gs payload + sscProcessDataDo coreConfig (epoch, richmen) bvd gs payload where checkSlot Nothing = throwError CurrentSlotUnknown checkSlot (Just si@SlotId {..}) - | isGoodSlotForTag tag siSlot = pass + | isGoodSlotForTag tag (configBlkSecurityParam coreConfig) siSlot = pass | CommitmentMsg <- tag = throwError $ NotCommitmentPhase si | OpeningMsg <- tag = throwError $ NotOpeningPhase si | SharesMsg <- tag = throwError $ NotSharesPhase si @@ -264,15 +264,15 @@ sscProcessData pm tag payload = executeMonadBaseRandom seed = hoist $ hoist (pure . fst . Rand.withDRG seed) sscProcessDataDo - :: (MonadState SscLocalData m, HasGenesisData - , WithLogger m, Rand.MonadRandom m, HasProtocolConstants) - => ProtocolMagic + :: ( MonadState SscLocalData m, HasGenesisData + , WithLogger m, Rand.MonadRandom m) + => Core.Config -> (EpochIndex, RichmenStakes) -> BlockVersionData -> SscGlobalState -> SscPayload -> m (Either SscVerifyError ()) -sscProcessDataDo pm richmenData bvd gs payload = +sscProcessDataDo coreConfig richmenData bvd gs payload = runExceptT $ do storedEpoch <- use ldEpoch let givenEpoch = fst richmenData @@ -289,14 +289,15 @@ sscProcessDataDo pm richmenData bvd gs payload = | otherwise -> evalPureTossWithLogger gs . supplyPureTossEnv (multiRichmen, bvd) . - execTossT mempty . refreshToss pm givenEpoch =<< + execTossT mempty . refreshToss coreConfig givenEpoch =<< use ldModifier newTM <- ExceptT $ evalPureTossWithLogger gs $ supplyPureTossEnv (multiRichmen, bvd) $ runExceptT $ - execTossT oldTM $ verifyAndApplySscPayload pm (Left storedEpoch) payload + execTossT oldTM $ + verifyAndApplySscPayload coreConfig (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/db/src/Pos/DB/Ssc/Logic/VAR.hs b/db/src/Pos/DB/Ssc/Logic/VAR.hs index 5833473b80f..e5fbc63d4af 100644 --- a/db/src/Pos/DB/Ssc/Logic/VAR.hs +++ b/db/src/Pos/DB/Ssc/Logic/VAR.hs @@ -28,14 +28,13 @@ import Pos.Chain.Ssc (HasSscConfiguration, MonadSscMem, runPureTossWithLogger, sscGlobal, sscIsCriticalVerifyError, sscRunGlobalUpdate, supplyPureTossEnv, verifyAndApplySscPayload) -import Pos.Core (HasCoreConfiguration, HasGenesisData, - HasProtocolConstants, epochIndexL, epochOrSlotG) +import Pos.Core as Core (Config, HasCoreConfiguration, HasGenesisData, + SlotCount, epochIndexL, epochOrSlotG) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Exception (assertionFailed) import Pos.Core.Reporting (MonadReporting, reportError) import Pos.Core.Ssc (SscPayload (..)) import Pos.Core.Update (BlockVersionData) -import Pos.Crypto (ProtocolMagic) import Pos.DB (MonadDBRead, MonadGState, SomeBatchOp (..), gsAdoptedBVData) import Pos.DB.Lrc (HasLrcContext, getSscRichmen) @@ -76,10 +75,10 @@ type SscGlobalApplyMode ctx m = SscGlobalVerifyMode ctx m -- All blocks must be from the same epoch. sscVerifyBlocks :: SscGlobalVerifyMode ctx m - => ProtocolMagic + => Core.Config -> OldestFirst NE SscBlock -> m (Either SscVerifyError SscGlobalState) -sscVerifyBlocks pm blocks = do +sscVerifyBlocks coreConfig blocks = do let epoch = blocks ^. _Wrapped . _neHead . epochIndexL let lastEpoch = blocks ^. _Wrapped . _neLast . epochIndexL let differentEpochsMsg = @@ -95,7 +94,7 @@ sscVerifyBlocks pm blocks = do gs <- readTVarIO globalVar res <- runExceptT - (execStateT (sscVerifyAndApplyBlocks pm richmenSet bvd blocks) gs) + (execStateT (sscVerifyAndApplyBlocks coreConfig richmenSet bvd blocks) gs) case res of Left e | sscIsCriticalVerifyError e -> @@ -112,19 +111,19 @@ sscVerifyBlocks pm blocks = do -- argument (it can be calculated in advance using 'sscVerifyBlocks'). sscApplyBlocks :: SscGlobalApplyMode ctx m - => ProtocolMagic + => Core.Config -> OldestFirst NE SscBlock -> Maybe SscGlobalState -> m [SomeBatchOp] -sscApplyBlocks pm blocks (Just newState) = do +sscApplyBlocks coreConfig blocks (Just newState) = do inAssertMode $ do let hashes = map headerHash blocks - expectedState <- sscVerifyValidBlocks pm blocks + expectedState <- sscVerifyValidBlocks coreConfig blocks if | newState == expectedState -> pass | otherwise -> onUnexpectedVerify hashes sscApplyBlocksFinish newState -sscApplyBlocks pm blocks Nothing = - sscApplyBlocksFinish =<< sscVerifyValidBlocks pm blocks +sscApplyBlocks coreConfig blocks Nothing = + sscApplyBlocksFinish =<< sscVerifyValidBlocks coreConfig blocks sscApplyBlocksFinish :: (SscGlobalApplyMode ctx m) @@ -138,11 +137,11 @@ sscApplyBlocksFinish gs = do sscVerifyValidBlocks :: SscGlobalApplyMode ctx m - => ProtocolMagic + => Core.Config -> OldestFirst NE SscBlock -> m SscGlobalState -sscVerifyValidBlocks pm blocks = - sscVerifyBlocks pm blocks >>= \case +sscVerifyValidBlocks coreConfig blocks = + sscVerifyBlocks coreConfig blocks >>= \case Left e -> onVerifyFailedInApply hashes e Right newState -> return newState where @@ -176,32 +175,32 @@ 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) - => ProtocolMagic + :: (SscVerifyMode m, HasGenesisData) + => Core.Config -> RichmenStakes -> BlockVersionData -> OldestFirst NE SscBlock -> m () -sscVerifyAndApplyBlocks pm richmenStake bvd blocks = - verifyAndApplyMultiRichmen pm False (richmenData, bvd) blocks +sscVerifyAndApplyBlocks coreConfig richmenStake bvd blocks = + verifyAndApplyMultiRichmen coreConfig False (richmenData, bvd) blocks where epoch = blocks ^. _Wrapped . _neHead . epochIndexL richmenData = HM.fromList [(epoch, richmenStake)] verifyAndApplyMultiRichmen - :: (SscVerifyMode m, HasProtocolConstants, HasGenesisData) - => ProtocolMagic + :: (SscVerifyMode m, HasGenesisData) + => Core.Config -> Bool -> (MultiRichmenStakes, BlockVersionData) -> OldestFirst NE SscBlock -> m () -verifyAndApplyMultiRichmen pm onlyCerts env = +verifyAndApplyMultiRichmen coreConfig onlyCerts env = tossToVerifier . hoist (supplyPureTossEnv env) . mapM_ verifyAndApplyDo where verifyAndApplyDo (ComponentBlockGenesis header) = applyGenesisBlock $ header ^. epochIndexL verifyAndApplyDo (ComponentBlockMain header payload) = - verifyAndApplySscPayload pm (Right header) $ + verifyAndApplySscPayload coreConfig (Right header) $ filterPayload payload filterPayload payload | onlyCerts = leaveOnlyCerts payload @@ -220,15 +219,15 @@ 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/db/src/Pos/DB/Ssc/State.hs b/db/src/Pos/DB/Ssc/State.hs index 81581d5df09..97763d7a841 100644 --- a/db/src/Pos/DB/Ssc/State.hs +++ b/db/src/Pos/DB/Ssc/State.hs @@ -11,7 +11,7 @@ import Universum import qualified Control.Concurrent.STM as STM import Pos.Chain.Ssc (SscState (..)) -import Pos.Core.Slotting (MonadSlots) +import Pos.Core.Slotting (MonadSlots, SlotCount) import Pos.DB (MonadDBRead) import Pos.Util.Wlog (WithLogger) @@ -20,13 +20,11 @@ import Pos.DB.Ssc.State.Global import Pos.DB.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/db/src/Pos/DB/Ssc/State/Global.hs b/db/src/Pos/DB/Ssc/State/Global.hs index 76333d39e96..6f80b0aea2d 100644 --- a/db/src/Pos/DB/Ssc/State/Global.hs +++ b/db/src/Pos/DB/Ssc/State/Global.hs @@ -20,8 +20,8 @@ import Universum import Pos.Chain.Ssc (MonadSscMem, SscGlobalState (..), getStableCertsPure, sgsVssCertificates, sscRunGlobalQuery) import qualified Pos.Chain.Ssc as Ssc -import Pos.Core (EpochIndex (..), HasGenesisData, - HasProtocolConstants, SlotId (..)) +import Pos.Core (BlockCount, EpochIndex (..), HasGenesisData, + SlotId (..)) import Pos.Core.Ssc (VssCertificatesMap (..)) import Pos.DB (MonadDBRead) import qualified Pos.DB.Ssc.GState as DB @@ -42,10 +42,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/db/src/Pos/DB/Ssc/State/Local.hs b/db/src/Pos/DB/Ssc/State/Local.hs index a1a1f15f2eb..e34de1b96ba 100644 --- a/db/src/Pos/DB/Ssc/State/Local.hs +++ b/db/src/Pos/DB/Ssc/State/Local.hs @@ -12,31 +12,32 @@ import Universum import Pos.Chain.Ssc (MonadSscMem, SscLocalData (..), askSscMem, sscLocal) -import Pos.Core (HasProtocolConstants, SlotId (..)) +import Pos.Core (SlotCount, SlotId (..), localSlotIndexMinBound) import Pos.Core.Slotting (MonadSlots (getCurrentSlot)) import Pos.DB (MonadDBRead) -- | 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/db/src/Pos/DB/Txp/Logic/Local.hs b/db/src/Pos/DB/Txp/Logic/Local.hs index b2503d9f84c..a95a8a3a2e3 100644 --- a/db/src/Pos/DB/Txp/Logic/Local.hs +++ b/db/src/Pos/DB/Txp/Logic/Local.hs @@ -32,7 +32,8 @@ import Pos.Chain.Txp (ExtendedLocalToilM, LocalToilState (..), UndoMap, Utxo, UtxoLookup, UtxoModifier, extendLocalToilM, mpLocalTxs, normalizeToil, processTx, topsortTxs, utxoToLookup) -import Pos.Core (EpochIndex, ProtocolMagic, siEpoch) +import Pos.Core as Core (Config (..), EpochIndex, SlotCount, + configEpochSlots, siEpoch) import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Core.JsonLog.LogEvents (MemPoolModifyReason (..)) import Pos.Core.Reporting (reportError) @@ -66,9 +67,9 @@ type TxpProcessTransactionMode ctx m = -- only. txProcessTransaction :: ( TxpProcessTransactionMode ctx m) - => ProtocolMagic -> TxpConfiguration -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -txProcessTransaction pm txpConfig itw = - withStateLock LowPriority ProcessTransaction $ \__tip -> txProcessTransactionNoLock pm txpConfig itw + => Core.Config -> TxpConfiguration -> (TxId, TxAux) -> m (Either ToilVerFailure ()) +txProcessTransaction coreConfig txpConfig itw = + withStateLock LowPriority ProcessTransaction $ \__tip -> txProcessTransactionNoLock coreConfig txpConfig itw -- | Unsafe version of 'txProcessTransaction' which doesn't take a -- lock. Can be used in tests. @@ -77,12 +78,14 @@ txProcessTransactionNoLock ( TxpLocalWorkMode ctx m , MempoolExt m ~ () ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -txProcessTransactionNoLock pm txpConfig = - txProcessTransactionAbstract buildContext processTxHoisted +txProcessTransactionNoLock coreConfig txpConfig = txProcessTransactionAbstract + (configEpochSlots coreConfig) + buildContext + processTxHoisted where buildContext :: Utxo -> TxAux -> m () buildContext _ _ = pure () @@ -93,16 +96,18 @@ txProcessTransactionNoLock pm txpConfig = -> (TxId, TxAux) -> ExceptT ToilVerFailure (ExtendedLocalToilM () ()) TxUndo processTxHoisted bvd = - mapExceptT extendLocalToilM ... (processTx pm txpConfig bvd) + mapExceptT extendLocalToilM + ... (processTx (configProtocolMagic coreConfig) txpConfig bvd) 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 @@ -118,7 +123,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 @@ -181,9 +186,10 @@ txNormalize ( TxpLocalWorkMode ctx m , MempoolExt m ~ () ) - => ProtocolMagic -> TxpConfiguration -> m () -txNormalize pm txpConfig = - txNormalizeAbstract buildContext $ normalizeToilHoisted + => Core.Config -> TxpConfiguration -> m () +txNormalize coreConfig txpConfig = + txNormalizeAbstract (configEpochSlots coreConfig) buildContext + $ normalizeToilHoisted where buildContext :: Utxo -> [TxAux] -> m () buildContext _ _ = pure () @@ -194,16 +200,18 @@ txNormalize pm txpConfig = -> HashMap TxId TxAux -> ExtendedLocalToilM () () () normalizeToilHoisted bvd epoch txs = - extendLocalToilM $ - normalizeToil pm txpConfig bvd epoch $ HM.toList txs + extendLocalToilM + $ normalizeToil (configProtocolMagic coreConfig) txpConfig bvd epoch + $ HM.toList txs txNormalizeAbstract :: (TxpLocalWorkMode ctx m, MempoolExt m ~ extraState) - => (Utxo -> [TxAux] -> m extraEnv) + => 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/db/src/Pos/DB/Txp/MemState/Class.hs b/db/src/Pos/DB/Txp/MemState/Class.hs index 099be8cfcc7..a456510e802 100644 --- a/db/src/Pos/DB/Txp/MemState/Class.hs +++ b/db/src/Pos/DB/Txp/MemState/Class.hs @@ -32,10 +32,10 @@ import qualified Data.HashMap.Strict as HM import Pos.Chain.Block (HeaderHash) import Pos.Chain.Txp (MemPool (..), ToilVerFailure, TxpConfiguration, UndoMap, UtxoModifier) +import Pos.Core as Core (Config) import Pos.Core.Reporting (MonadReporting) import Pos.Core.Slotting (MonadSlots (..)) import Pos.Core.Txp (TxAux, TxId) -import Pos.Crypto (ProtocolMagic) import Pos.DB.Class (MonadDBRead, MonadGState (..)) import Pos.DB.Txp.MemState.Types (GenericTxpLocalData (..)) import Pos.Util.Util (HasLens (..)) @@ -129,8 +129,8 @@ clearTxpMemPool txpData = do type family MempoolExt (m :: * -> *) :: * class Monad m => MonadTxpLocal m where - txpNormalize :: ProtocolMagic -> TxpConfiguration -> m () - txpProcessTx :: ProtocolMagic -> TxpConfiguration -> (TxId, TxAux) -> m (Either ToilVerFailure ()) + txpNormalize :: Core.Config -> TxpConfiguration -> m () + txpProcessTx :: Core.Config -> TxpConfiguration -> (TxId, TxAux) -> m (Either ToilVerFailure ()) type TxpLocalWorkMode ctx m = ( MonadIO m diff --git a/db/src/Pos/DB/Update/Context.hs b/db/src/Pos/DB/Update/Context.hs index 857db4113be..218fcf00345 100644 --- a/db/src/Pos/DB/Update/Context.hs +++ b/db/src/Pos/DB/Update/Context.hs @@ -8,7 +8,7 @@ module Pos.DB.Update.Context import Universum import Pos.Chain.Update (ConfirmedProposalState) -import Pos.Core.Slotting (MonadSlots) +import Pos.Core.Slotting (MonadSlots, SlotCount) import Pos.DB.Class (MonadDBRead) import Pos.DB.Update.MemState.Types (MemVar, newMemVar) @@ -27,10 +27,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/db/src/Pos/DB/Update/GState.hs b/db/src/Pos/DB/Update/GState.hs index 4389dfcdb90..9bc828a974e 100644 --- a/db/src/Pos/DB/Update/GState.hs +++ b/db/src/Pos/DB/Update/GState.hs @@ -58,8 +58,9 @@ import Pos.Chain.Update (BlockVersionState (..), cpsSoftwareVersion, genesisBlockVersion, genesisSoftwareVersions, ourAppName, ourSystemTag, psProposal) -import Pos.Core (ChainDifficulty, HasCoreConfiguration, SlotId, - StakeholderId, TimeDiff (..), epochSlots) +import Pos.Core (ChainDifficulty, HasCoreConfiguration, + ProtocolConstants, SlotId, StakeholderId, TimeDiff (..), + pcEpochSlots) import Pos.Core.Configuration (genesisBlockVersionData) import Pos.Core.Slotting (EpochSlottingData (..), SlottingData, createInitSlottingData) @@ -170,8 +171,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 : @@ -181,7 +182,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/db/src/Pos/DB/Update/Logic/Global.hs b/db/src/Pos/DB/Update/Logic/Global.hs index 1a015824231..8be7a43c613 100644 --- a/db/src/Pos/DB/Update/Logic/Global.hs +++ b/db/src/Pos/DB/Update/Logic/Global.hs @@ -24,8 +24,9 @@ import Pos.Chain.Update (BlockVersionState, ConfirmedProposalState, PollT, PollVerFailure, ProposalState, USUndo, execPollT, execRollT, getAdoptedBV, lastKnownBlockVersion, reportUnexpectedError, runPollT) -import Pos.Core (HasCoreConfiguration, HasProtocolConstants, - ProtocolMagic, StakeholderId, addressHash, epochIndexL) +import Pos.Core as Core (Config, HasCoreConfiguration, StakeholderId, + addressHash, configBlkSecurityParam, configEpochSlots, + epochIndexL) import Pos.Core.Chrono (NE, NewestFirst, OldestFirst) import Pos.Core.Exception (reportFatalError) import Pos.Core.Reporting (MonadReporting) @@ -100,22 +101,22 @@ usApplyBlocks :: ( MonadThrow m , USGlobalApplyMode ctx m ) - => ProtocolMagic + => Core.Config -> OldestFirst NE UpdateBlock -> Maybe PollModifier -> m [DB.SomeBatchOp] -usApplyBlocks pm blocks modifierMaybe = +usApplyBlocks coreConfig blocks modifierMaybe = withUSLogger $ processModifier =<< case modifierMaybe of Nothing -> do - verdict <- usVerifyBlocks pm False blocks + verdict <- usVerifyBlocks coreConfig 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 coreConfig False blocks whenLeft verdict $ \v -> onFailure v return modifier where @@ -165,18 +166,18 @@ usVerifyBlocks :: , MonadUnliftIO m , MonadReporting m ) - => ProtocolMagic + => Core.Config -> Bool -> OldestFirst NE UpdateBlock -> m (Either PollVerFailure (PollModifier, OldestFirst NE USUndo)) -usVerifyBlocks pm verifyAllIsKnown blocks = +usVerifyBlocks coreConfig verifyAllIsKnown blocks = withUSLogger $ reportUnexpectedError $ processRes <$> run (runExceptT action) where action = do lastAdopted <- getAdoptedBV - mapM (verifyBlock pm lastAdopted verifyAllIsKnown) blocks + mapM (verifyBlock coreConfig lastAdopted verifyAllIsKnown) blocks run :: PollT (DBPoll n) a -> n (a, PollModifier) run = runDBPoll . runPollT def processRes :: @@ -186,14 +187,19 @@ 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) + => Core.Config + -> BlockVersion + -> Bool + -> UpdateBlock + -> m USUndo +verifyBlock coreConfig _ _ (ComponentBlockGenesis genBlk) = + execRollT $ processGenesisBlock (configEpochSlots coreConfig) + (genBlk ^. epochIndexL) +verifyBlock coreConfig lastAdopted verifyAllIsKnown (ComponentBlockMain header payload) = execRollT $ do verifyAndApplyUSPayload - pm + coreConfig lastAdopted verifyAllIsKnown (Right header) @@ -204,6 +210,7 @@ verifyBlock pm lastAdopted verifyAllIsKnown (ComponentBlockMain header payload) -- we assume that block version is confirmed. let leaderPk = header ^. headerLeaderKeyL recordBlockIssuance + (configBlkSecurityParam coreConfig) (addressHash leaderPk) (header ^. blockVersionL) (header ^. headerSlotL) diff --git a/db/src/Pos/DB/Update/Logic/Local.hs b/db/src/Pos/DB/Update/Logic/Local.hs index 7998bf9ac93..54058d4d5ee 100644 --- a/db/src/Pos/DB/Update/Logic/Local.hs +++ b/db/src/Pos/DB/Update/Logic/Local.hs @@ -41,7 +41,7 @@ import Pos.Chain.Update (HasUpdateConfiguration, PollVerFailure (..), canCombineVotes, evalPollT, execPollT, getAdoptedBV, modifyPollModifier, psVotes, reportUnexpectedError, runPollT) -import Pos.Core (ProtocolMagic, SlotId (..), slotIdF) +import Pos.Core as Core (Config, SlotId (..), slotIdF) import Pos.Core.Reporting (MonadReporting) import Pos.Core.Update (BlockVersionData (..), UpId, UpdatePayload (..), UpdateProposal, UpdateVote (..)) @@ -128,10 +128,10 @@ processSkeleton :: ( USLocalLogicModeWithLock ctx m , MonadReporting m ) - => ProtocolMagic + => Core.Config -> UpdatePayload -> m (Either PollVerFailure ()) -processSkeleton pm payload = +processSkeleton coreConfig payload = reportUnexpectedError $ withUSLock $ runExceptT $ @@ -158,7 +158,7 @@ processSkeleton pm payload = modifierOrFailure <- lift . runDBPoll . runExceptT . evalPollT msModifier . execPollT def $ do lastAdopted <- getAdoptedBV - verifyAndApplyUSPayload pm lastAdopted True (Left msSlot) payload + verifyAndApplyUSPayload coreConfig lastAdopted True (Left msSlot) payload case modifierOrFailure of Left failure -> throwError failure Right modifier -> do @@ -218,11 +218,12 @@ 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) + => Core.Config + -> UpdateProposal + -> m (Either PollVerFailure ()) +processProposal coreConfig proposal = + processSkeleton coreConfig $ UpdatePayload (Just proposal) [] ---------------------------------------------------------------------------- -- Votes @@ -269,11 +270,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) + => Core.Config + -> UpdateVote + -> m (Either PollVerFailure ()) +processVote coreConfig vote = + processSkeleton coreConfig $ UpdatePayload Nothing [vote] ---------------------------------------------------------------------------- -- Normalization and related diff --git a/db/src/Pos/DB/Update/MemState/Types.hs b/db/src/Pos/DB/Update/MemState/Types.hs index 2a173a04183..d176e3b4a02 100644 --- a/db/src/Pos/DB/Update/MemState/Types.hs +++ b/db/src/Pos/DB/Update/MemState/Types.hs @@ -19,7 +19,7 @@ import Serokell.Data.Memory.Units (Byte) import Pos.Chain.Block (HeaderHash) import Pos.Chain.Update (LocalVotes, PollModifier) -import Pos.Core (SlotId (..)) +import Pos.Core (SlotCount, SlotId (..), localSlotIndexMinBound) import Pos.Core.Slotting (MonadSlots (getCurrentSlot)) import Pos.Core.Update (UpdateProposals) import Pos.DB.Class (MonadDBRead) @@ -57,11 +57,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/db/src/Pos/DB/Update/Poll/Logic/Apply.hs b/db/src/Pos/DB/Update/Poll/Logic/Apply.hs index 966e15988d8..5ccac556678 100644 --- a/db/src/Pos/DB/Update/Poll/Logic/Apply.hs +++ b/db/src/Pos/DB/Update/Poll/Logic/Apply.hs @@ -24,13 +24,13 @@ import Pos.Chain.Update (ConfirmedProposalState (..), MonadPollRead (..), PollVerFailure (..), ProposalState (..), UndecidedProposalState (..), UpsExtra (..), psProposal) -import Pos.Core (ChainDifficulty (..), Coin, EpochIndex, - HasProtocolConstants, ProtocolMagic, SlotId (..), +import Pos.Core as Core (BlockCount, ChainDifficulty (..), Coin, + Config (..), EpochIndex, SlotCount, SlotId (..), addressHash, applyCoinPortionUp, coinToInteger, - difficultyL, epochIndexL, flattenSlotId, sumCoins, - unflattenSlotId, unsafeIntegerToCoin) + configBlkSecurityParam, configEpochSlots, difficultyL, + epochIndexL, flattenSlotId, sumCoins, unflattenSlotId, + unsafeIntegerToCoin) import Pos.Core.Attributes (areAttributesKnown) -import Pos.Core.Configuration (blkSecurityParam) import Pos.Core.Update (BlockVersion, BlockVersionData (..), SoftwareVersion (..), UpId, UpdatePayload (..), UpdateProposal (..), UpdateVote (..), blockVersionL, @@ -64,17 +64,18 @@ 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) - => ProtocolMagic +verifyAndApplyUSPayload + :: ApplyMode m + => Core.Config -> BlockVersion -> Bool -> Either SlotId (Some IsMainHeader) -> UpdatePayload -> m () -verifyAndApplyUSPayload pm lastAdopted verifyAllIsKnown slotOrHeader upp@UpdatePayload {..} = do +verifyAndApplyUSPayload coreConfig lastAdopted verifyAllIsKnown slotOrHeader upp@UpdatePayload {..} = do -- First of all, we verify data. - either (throwError . PollInvalidUpdatePayload) pure =<< runExceptT (checkUpdatePayload pm upp) + either (throwError . PollInvalidUpdatePayload) pure + =<< runExceptT (checkUpdatePayload (configProtocolMagic coreConfig) upp) whenRight slotOrHeader $ verifyHeader lastAdopted unless isEmptyPayload $ do @@ -102,10 +103,12 @@ verifyAndApplyUSPayload pm lastAdopted verifyAllIsKnown slotOrHeader upp@UpdateP Left _ -> pass Right mainHeader -> do applyImplicitAgreement + (configEpochSlots coreConfig) (mainHeader ^. headerSlotL) (mainHeader ^. difficultyL) (mainHeader ^. headerHashG) applyDepthCheck + (configBlkSecurityParam coreConfig) (mainHeader ^. epochIndexL) (mainHeader ^. headerHashG) (mainHeader ^. difficultyL) @@ -276,11 +279,11 @@ 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) $ @@ -307,12 +310,12 @@ 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/db/src/Pos/DB/Update/Poll/Logic/Base.hs b/db/src/Pos/DB/Update/Poll/Logic/Base.hs index 945f1d78de0..9c858eb5bdf 100644 --- a/db/src/Pos/DB/Update/Poll/Logic/Base.hs +++ b/db/src/Pos/DB/Update/Poll/Logic/Base.hs @@ -46,12 +46,11 @@ import Pos.Chain.Update (BlockVersionState (..), UndecidedProposalState (..), UpsExtra (..), bvsIsConfirmed, combineVotes, cpsBlockVersion, isPositiveVote, newVoteState) -import Pos.Core (Coin, CoinPortion (..), EpochIndex, - HasProtocolConstants, SlotId, TimeDiff (..), addressHash, - applyCoinPortionUp, coinPortionDenominator, coinToInteger, - difficultyL, epochSlots, getCoinPortion, isBootstrapEra, - sumCoins, unsafeAddCoin, unsafeIntegerToCoin, - unsafeSubCoin) +import Pos.Core (Coin, CoinPortion (..), EpochIndex, SlotCount, + SlotId, TimeDiff (..), addressHash, applyCoinPortionUp, + coinPortionDenominator, coinToInteger, difficultyL, + getCoinPortion, isBootstrapEra, sumCoins, unsafeAddCoin, + unsafeIntegerToCoin, unsafeSubCoin) import Pos.Core.Slotting (EpochSlottingData (..), SlottingData, addEpochSlottingData, getCurrentEpochIndex, getNextEpochSlottingData) @@ -198,10 +197,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/db/src/Pos/DB/Update/Poll/Logic/Softfork.hs b/db/src/Pos/DB/Update/Poll/Logic/Softfork.hs index 754f2f6787f..a646f14e8e8 100644 --- a/db/src/Pos/DB/Update/Poll/Logic/Softfork.hs +++ b/db/src/Pos/DB/Update/Poll/Logic/Softfork.hs @@ -20,7 +20,7 @@ import Serokell.Util.Text (listJson) import Pos.Chain.Block (HeaderHash) import Pos.Chain.Update (BlockVersionState (..), MonadPoll (..), MonadPollRead (..), PollVerFailure (..)) -import Pos.Core (Coin, EpochIndex, HasProtocolConstants, SlotId (..), +import Pos.Core (BlockCount, Coin, EpochIndex, SlotCount, SlotId (..), StakeholderId, crucialSlot, sumCoins, unsafeIntegerToCoin) import Pos.Core.Update (BlockVersion, BlockVersionData (..), SoftforkRule (..)) @@ -33,13 +33,18 @@ import Pos.Util.Wlog (logInfo) -- | 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 {..} @@ -72,9 +77,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 @@ -97,7 +105,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/db/test/Test/Pos/DB/Block/Arbitrary.hs b/db/test/Test/Pos/DB/Block/Arbitrary.hs index c7dbf6a45f2..5233a085279 100644 --- a/db/test/Test/Pos/DB/Block/Arbitrary.hs +++ b/db/test/Test/Pos/DB/Block/Arbitrary.hs @@ -9,7 +9,6 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, genericShrink) import Pos.Chain.Block (SlogUndo, Undo (..)) -import Pos.Core (HasProtocolConstants) import Test.Pos.Chain.Delegation.Arbitrary () import Test.Pos.Core.Arbitrary () @@ -20,6 +19,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/db/test/Test/Pos/DB/Update/Arbitrary/Poll.hs b/db/test/Test/Pos/DB/Update/Arbitrary/Poll.hs index 59a98f03685..0195a6d8086 100644 --- a/db/test/Test/Pos/DB/Update/Arbitrary/Poll.hs +++ b/db/test/Test/Pos/DB/Update/Arbitrary/Poll.hs @@ -21,7 +21,6 @@ import Pos.Chain.Update (BlockVersionState (..), DpsExtra (..), PollModifier (..), PrevValue, ProposalState (..), USUndo, UndecidedProposalState (..), UpsExtra (..)) -import Pos.Core.Configuration (HasProtocolConstants) import Pos.DB.Update (PollState (..), psActivePropsIdx) import Test.Pos.Chain.Update.Arbitrary () @@ -33,7 +32,7 @@ instance Arbitrary UpsExtra where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary UndecidedProposalState where +instance Arbitrary UndecidedProposalState where arbitrary = genericArbitrary shrink = genericShrink @@ -41,7 +40,7 @@ instance Arbitrary DpsExtra where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary DecidedProposalState where +instance Arbitrary DecidedProposalState where arbitrary = genericArbitrary shrink = genericShrink @@ -49,7 +48,7 @@ instance Arbitrary ConfirmedProposalState where arbitrary = genericArbitrary shrink = genericShrink -instance HasProtocolConstants => Arbitrary ProposalState where +instance Arbitrary ProposalState where arbitrary = genericArbitrary shrink = genericShrink @@ -57,17 +56,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/explorer/Makefile b/explorer/Makefile new file mode 100644 index 00000000000..063fcca3277 --- /dev/null +++ b/explorer/Makefile @@ -0,0 +1,13 @@ +help: ## Print documentation + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +ghcid: ## Run ghcid with the cardano-sl-explorer package + ghcid \ + --command "stack ghci cardano-sl-explorer --ghci-options=-fno-code" + +ghcid-test: ## Have ghcid run the test suite for the wallet-new-specs on successful recompile + ghcid \ + --command "stack ghci cardano-sl-explorer:lib cardano-sl-explorer:test:cardano-explorer-test --ghci-options=-fobject-code" \ + --test "Main.main" + +.PHONY: ghcid ghcid-test help diff --git a/explorer/bench/Bench/Pos/Explorer/ServerBench.hs b/explorer/bench/Bench/Pos/Explorer/ServerBench.hs index 98f5c93cb71..c267923c69d 100644 --- a/explorer/bench/Bench/Pos/Explorer/ServerBench.hs +++ b/explorer/bench/Bench/Pos/Explorer/ServerBench.hs @@ -22,6 +22,7 @@ import Pos.Explorer.Web.Server (getBlocksPage, getBlocksTotal) import Test.Pos.Configuration (withDefConfigurations) import Test.Pos.Core.Arbitrary.Txp.Unsafe () +import Test.Pos.Core.Dummy (dummyEpochSlots) ---------------------------------------------------------------- -- Mocked functions @@ -41,8 +42,11 @@ getBlocksTotalBench (testParams, extraContext) = getBlocksPageBench :: BenchmarkTestParams -> IO (Integer, [CBlockEntry]) getBlocksPageBench (testParams, extraContext) = withDefConfigurations $ \_ _ _ -> - runExplorerTestMode testParams extraContext - $ getBlocksPage Nothing (Just $ fromIntegral defaultPageSize) + runExplorerTestMode testParams extraContext + $ 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 diff --git a/explorer/cardano-sl-explorer.cabal b/explorer/cardano-sl-explorer.cabal index af45568bdb1..1ad75fa0b8f 100644 --- a/explorer/cardano-sl-explorer.cabal +++ b/explorer/cardano-sl-explorer.cabal @@ -86,6 +86,7 @@ library , cardano-sl-chain , cardano-sl-chain-test , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto , cardano-sl-crypto-test , cardano-sl-db diff --git a/explorer/src/Pos/Explorer/BListener.hs b/explorer/src/Pos/Explorer/BListener.hs index 3d5fbe54f8b..36e36710434 100644 --- a/explorer/src/Pos/Explorer/BListener.hs +++ b/explorer/src/Pos/Explorer/BListener.hs @@ -77,8 +77,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 ccd99973ba2..10f9c161e51 100644 --- a/explorer/src/Pos/Explorer/DB.hs +++ b/explorer/src/Pos/Explorer/DB.hs @@ -44,11 +44,10 @@ import Pos.Binary.Class (serialize') import Pos.Chain.Block (HeaderHash) import Pos.Chain.Txp (GenesisUtxo (..), genesisUtxo, utxoF, utxoToAddressCoinPairs) -import Pos.Core (Address, Coin, EpochIndex (..), HasConfiguration, - SlotCount, coinToInteger, unsafeAddCoin) +import Pos.Core as Core (Address, Coin, Config, EpochIndex (..), + HasConfiguration, coinToInteger, unsafeAddCoin) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Txp (Tx, TxId, TxOut (..), TxOutAux (..)) -import Pos.Crypto (ProtocolMagic) import Pos.DB (DBError (..), DBIteratorClass (..), DBTag (GStateDB), MonadDB, MonadDBRead (dbGet), RocksBatchOp (..), dbIterSource, dbSerializeValue, encodeWithKeyPrefix) @@ -59,16 +58,12 @@ import Pos.Explorer.Core (AddrHistory, TxExtra (..)) import Pos.Util.Util (maybeThrow) import Pos.Util.Wlog (WithLogger, logError) - - 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) + => Core.Config + -> m () +explorerInitDB coreConfig = initNodeDBs coreConfig >> prepareExplorerDB ---------------------------------------------------------------------------- -- Types diff --git a/explorer/src/Pos/Explorer/ExplorerMode.hs b/explorer/src/Pos/Explorer/ExplorerMode.hs index 12cc023888d..9a35d5ec8da 100644 --- a/explorer/src/Pos/Explorer/ExplorerMode.hs +++ b/explorer/src/Pos/Explorer/ExplorerMode.hs @@ -23,7 +23,7 @@ import Test.QuickCheck (Gen, Property, Testable (..), arbitrary, forAll, ioProperty) import Test.QuickCheck.Monadic (PropertyM, monadic) -import Pos.Core (SlotId, Timestamp (..), epochSlots) +import Pos.Core (SlotId, Timestamp (..)) import Pos.Core.Conc (currentTime) import Pos.DB (MonadGState (..)) import qualified Pos.DB as DB @@ -60,7 +60,7 @@ import Pos.WorkMode (MinWorkMode) -- Need Emulation because it has instance Mockable CurrentTime import Test.Pos.Block.Logic.Emulation (Emulation (..), runEmulation) import Test.Pos.Block.Logic.Mode (TestParams (..)) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Core.Dummy (dummyConfig, dummyEpochSlots) ------------------------------------------------------------------------------------- @@ -148,13 +148,13 @@ initExplorerTestContext tp@TestParams {..} = do { eticDBPureVar = dbPureVar } liftIO $ runTestInitMode initCtx $ do - DB.initNodeDBs dummyProtocolMagic epochSlots + DB.initNodeDBs dummyConfig 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 @@ -242,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 f9256262ed1..f38db3c6f62 100644 --- a/explorer/src/Pos/Explorer/Socket/App.hs +++ b/explorer/src/Pos/Explorer/Socket/App.hs @@ -37,7 +37,7 @@ import Network.Wai.Middleware.Cors (CorsResourcePolicy, Origin, cors, import Serokell.Util.Text (listJson) import Pos.Chain.Block (Blund) -import Pos.Core (addressF, siEpoch) +import Pos.Core (SlotCount, addressF, siEpoch) import Pos.Core.Conc (withAsync) import qualified Pos.GState as DB import Pos.Infra.Slotting (MonadSlots (getCurrentSlot)) @@ -162,10 +162,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 @@ -190,10 +188,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) @@ -218,11 +216,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 bc64430dff2..8bfdf11a5e4 100644 --- a/explorer/src/Pos/Explorer/Socket/Methods.hs +++ b/explorer/src/Pos/Explorer/Socket/Methods.hs @@ -65,7 +65,7 @@ import Formatting (sformat, shown, stext, (%)) import Network.EngineIO (SocketId) import Network.SocketIO (Socket, socketId) import Pos.Chain.Block (Block, Blund, HeaderHash, mainBlockTxPayload) -import Pos.Core (Address) +import Pos.Core (Address, SlotCount) import Pos.Core.Chrono (getOldestFirst) import Pos.Core.Txp (Tx (..), TxOut (..), TxOutAux (..), txOutAddress, txpTxs) @@ -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 7a10da58999..5dceb376fea 100644 --- a/explorer/src/Pos/Explorer/TestUtil.hs +++ b/explorer/src/Pos/Explorer/TestUtil.hs @@ -40,14 +40,14 @@ import Pos.Chain.Ssc (defaultSscPayload) import Pos.Chain.Update (HasUpdateConfiguration) import qualified Pos.Communication () import Pos.Core (Address, BlockCount (..), ChainDifficulty (..), - Config (..), EpochIndex (..), GenesisHash (..), - HasConfiguration, LocalSlotIndex (..), SlotId (..), - SlotLeaders, StakeholderId, difficultyL, genesisHash, + EpochIndex (..), GenesisHash (..), HasConfiguration, + LocalSlotIndex (..), SlotId (..), SlotLeaders, + StakeholderId, difficultyL, genesisHash, makePubKeyAddressBoot) 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.DB.Block (RawPayload (..), createMainBlockPure) import Pos.Explorer.BListener (createPagedHeaderHashesPair) import Pos.Explorer.DB (Epoch, EpochPagedBlocksKey, Page, @@ -56,6 +56,7 @@ import Pos.Explorer.ExtraContext (ExplorerMockableMode (..)) import Test.Pos.Chain.Block.Arbitrary () import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Core.Dummy (dummyConfig, dummyK) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) @@ -88,15 +89,13 @@ generateValidExplorerMockableMode blocksNumber slotsPerEpoch = do blocks <- withDefConfigurations $ \_ _ _ -> produceBlocksByBlockNumberAndSlots blocksNumber slotsPerEpoch slotLeaders secretKeys - let tipBlock = Prelude.last blocks - let pagedHHs = withDefConfigurations $ \coreConfig _ _ -> - createMapPageHHs blocks $ configProtocolMagic coreConfig - let hHsBlunds = withDefConfigurations $ \coreConfig _ _ -> - createMapHHsBlund blocks $ configProtocolMagic coreConfig - let epochPageHHs = withDefConfigurations $ \coreConfig _ _ -> - createMapEpochPageHHs blocks slotsPerEpoch $ configProtocolMagic coreConfig - let mapEpochMaxPages = withDefConfigurations $ \coreConfig _ _ -> - createMapEpochMaxPages (keys epochPageHHs) $ configProtocolMagic coreConfig + let tipBlock = Prelude.last blocks + let pagedHHs = withDefConfigurations $ \_ _ _ -> createMapPageHHs blocks + let hHsBlunds = withDefConfigurations $ \_ _ _ -> createMapHHsBlund blocks + let epochPageHHs = withDefConfigurations + $ \_ _ _ -> createMapEpochPageHHs blocks slotsPerEpoch + let mapEpochMaxPages = withDefConfigurations + $ \_ _ _ -> createMapEpochMaxPages (keys epochPageHHs) pure $ ExplorerMockableMode { emmGetTipBlock = pure tipBlock @@ -109,12 +108,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)) @@ -123,9 +122,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])] @@ -145,9 +143,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 @@ -182,17 +179,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 @@ -208,7 +202,7 @@ basicBlock prevHeader sk slotId = producePureBlock infLimit sk emptyBlk - :: (HasConfiguration, HasUpdateConfiguration, Testable p) + :: (HasUpdateConfiguration, Testable p) => (Either Text MainBlock -> p) -> Property emptyBlk testableBlock = @@ -224,14 +218,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] @@ -243,7 +237,7 @@ producePureBlock -> SecretKey -> Either Text MainBlock producePureBlock limit prev txs psk slot dlgPay sscPay usPay sk = - createMainBlockPure dummyProtocolMagic limit prev psk slot sk $ + createMainBlockPure dummyConfig 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 2f9f91f556e..e8b97c6a1be 100644 --- a/explorer/src/Pos/Explorer/Txp/Global.hs +++ b/explorer/src/Pos/Explorer/Txp/Global.hs @@ -11,7 +11,8 @@ import qualified Data.HashMap.Strict as HM import Pos.Chain.Block (ComponentBlock (..), HeaderHash, headerHash, headerSlotL) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Core (HasConfiguration, SlotId (..), epochIndexL) +import Pos.Core (HasConfiguration, SlotId (..), epochIndexL, + localSlotIndexMinBound) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Txp (TxAux, TxUndo) import Pos.Crypto (ProtocolMagic) @@ -63,7 +64,7 @@ rollbackSettings = } applySingle :: - forall ctx m. (HasConfiguration, TxpGlobalApplyMode ctx m) + 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 @@ -79,7 +80,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 30a25d7aeca..e8ccd31a464 100644 --- a/explorer/src/Pos/Explorer/Txp/Local.hs +++ b/explorer/src/Pos/Explorer/Txp/Local.hs @@ -13,11 +13,11 @@ import Universum import qualified Data.HashMap.Strict as HM import Pos.Chain.Txp (ToilVerFailure (..), TxpConfiguration, Utxo) -import Pos.Core (EpochIndex, Timestamp) +import Pos.Core as Core (Config (..), EpochIndex, Timestamp, + configEpochSlots) import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Core.Txp (TxAux (..), TxId) import Pos.Core.Update (BlockVersionData) -import Pos.Crypto (ProtocolMagic) import Pos.DB.Txp.Logic (txNormalizeAbstract, txProcessTransactionAbstract) import Pos.DB.Txp.MemState (MempoolExt, TxpLocalWorkMode, getTxpExtra, @@ -47,27 +47,32 @@ eTxProcessTransaction :: , HasLens' ctx (StateLockMetrics MemPoolModifyReason) , CanJsonLog m ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -eTxProcessTransaction pm txpConfig itw = - withStateLock LowPriority ProcessTransaction $ \__tip -> eTxProcessTransactionNoLock pm txpConfig itw +eTxProcessTransaction coreConfig txpConfig itw = + withStateLock LowPriority ProcessTransaction + $ \__tip -> eTxProcessTransactionNoLock coreConfig txpConfig itw eTxProcessTransactionNoLock :: forall ctx m. (ETxpLocalWorkMode ctx m) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -eTxProcessTransactionNoLock pm txpConfig itw = getCurrentSlot >>= \case +eTxProcessTransactionNoLock coreConfig txpConfig 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 buildContext (processTx' mTxTimestamp) itw + txProcessTransactionAbstract epochSlots + buildContext + (processTx' mTxTimestamp) + itw where + epochSlots = configEpochSlots coreConfig buildContext :: Utxo -> TxAux -> m ExplorerExtraLookup buildContext utxo = buildExplorerExtraLookup utxo . one @@ -77,20 +82,27 @@ eTxProcessTransactionNoLock pm txpConfig itw = getCurrentSlot >>= \case -> EpochIndex -> (TxId, TxAux) -> ExceptT ToilVerFailure ELocalToilM () - processTx' mTxTimestamp bvd epoch tx = - eProcessTx pm txpConfig bvd epoch tx (TxExtra Nothing mTxTimestamp) + processTx' mTxTimestamp bvd epoch tx = eProcessTx + (configProtocolMagic coreConfig) + txpConfig + bvd + epoch + tx + (TxExtra Nothing mTxTimestamp) -- | 1. Recompute UtxoView by current MemPool -- 2. Remove invalid transactions from MemPool -- 3. Set new tip to txp local data eTxNormalize :: forall ctx m . (ETxpLocalWorkMode ctx m) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> m () -eTxNormalize pm txpConfig = do +eTxNormalize coreConfig txpConfig = do extras <- MM.insertionsMap . view eemLocalTxsExtra <$> withTxpLocalData getTxpExtra - txNormalizeAbstract buildExplorerExtraLookup (normalizeToil' extras) + txNormalizeAbstract (configEpochSlots coreConfig) + buildExplorerExtraLookup + (normalizeToil' extras) where normalizeToil' :: HashMap TxId TxExtra @@ -100,4 +112,8 @@ eTxNormalize pm txpConfig = do -> ELocalToilM () normalizeToil' extras bvd epoch txs = let toNormalize = HM.toList $ HM.intersectionWith (,) txs extras - in eNormalizeToil pm txpConfig bvd epoch toNormalize + in eNormalizeToil (configProtocolMagic coreConfig) + txpConfig + bvd + epoch + toNormalize diff --git a/explorer/src/Pos/Explorer/Web/ClientTypes.hs b/explorer/src/Pos/Explorer/Web/ClientTypes.hs index 37c9d249860..8c5f57433be 100644 --- a/explorer/src/Pos/Explorer/Web/ClientTypes.hs +++ b/explorer/src/Pos/Explorer/Web/ClientTypes.hs @@ -73,7 +73,7 @@ import Pos.Binary (biSize) import Pos.Chain.Block (MainBlock, Undo (..), gbHeader, gbhConsensus, headerHash, mainBlockSlot, mainBlockTxPayload, mcdSlot, prevBlockL) -import Pos.Core (Address, Coin, EpochIndex, LocalSlotIndex, +import Pos.Core (Address, Coin, EpochIndex, LocalSlotIndex, SlotCount, SlotId (..), StakeholderId, Timestamp, addressF, coinToInteger, decodeTextAddress, getEpochIndex, getSlotIndex, mkCoin, sumCoins, timestampToPosix, @@ -209,9 +209,10 @@ instance NFData CBlockEntry toBlockEntry :: ExplorerMode ctx m - => (MainBlock, Undo) + => SlotCount + -> (MainBlock, Undo) -> m CBlockEntry -toBlockEntry (blk, Undo{..}) = do +toBlockEntry epochSlots (blk, Undo{..}) = do blkSlotStart <- getSlotStartCSLI $ blk ^. gbHeader . gbhConsensus . mcdSlot @@ -221,7 +222,7 @@ toBlockEntry (blk, Undo{..}) = do slotIndex = siSlot blkHeaderSlot -- Find the epoch and slot leader - epochSlotLeader <- LrcDB.getLeader $ SlotId epochIndex slotIndex + epochSlotLeader <- LrcDB.getLeader epochSlots $ SlotId epochIndex slotIndex -- Fill required fields for @CBlockEntry@ let cbeEpoch = getEpochIndex epochIndex @@ -276,10 +277,11 @@ data CBlockSummary = CBlockSummary toBlockSummary :: ExplorerMode ctx m - => (MainBlock, Undo) + => SlotCount + -> (MainBlock, Undo) -> m CBlockSummary -toBlockSummary blund@(blk, _) = do - cbsEntry <- toBlockEntry blund +toBlockSummary epochSlots blund@(blk, _) = do + cbsEntry <- toBlockEntry epochSlots blund cbsNextHash <- fmap toCHash <$> GS.resolveForwardLink blk let blockTxs = blk ^. mainBlockTxPayload . txpTxs diff --git a/explorer/src/Pos/Explorer/Web/Server.hs b/explorer/src/Pos/Explorer/Web/Server.hs index e09d43779ef..169f131143f 100644 --- a/explorer/src/Pos/Explorer/Web/Server.hs +++ b/explorer/src/Pos/Explorer/Web/Server.hs @@ -61,10 +61,11 @@ import Pos.Chain.Block (Block, Blund, HeaderHash, MainBlock, Undo, mcdSlot) import Pos.Chain.Txp (TxMap, mpLocalTxs, topsortTxs) import Pos.Core (AddrType (..), Address (..), Coin, EpochIndex, - Timestamp, coinToInteger, difficultyL, getChainDifficulty, - isUnknownAddressType, makeRedeemAddress, siEpoch, siSlot, - sumCoins, timestampToPosix, unsafeAddCoin, - unsafeIntegerToCoin, unsafeSubCoin) + SlotCount, Timestamp, coinToInteger, difficultyL, + getChainDifficulty, isUnknownAddressType, + makeRedeemAddress, siEpoch, siSlot, sumCoins, + timestampToPosix, unsafeAddCoin, unsafeIntegerToCoin, + unsafeSubCoin) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Txp (Tx (..), TxAux, TxId, TxIn (..), TxOutAux (..), taTx, txOutAddress, txOutValue, txpTxs, _txOutputs) @@ -126,24 +127,24 @@ explorerApp serv = serve explorerApi <$> serv explorerHandlers :: forall ctx m. ExplorerMode ctx m - => Diffusion m -> ServerT ExplorerApi m -explorerHandlers _diffusion = + => 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 , _addressUtxoBulk = getAddressUtxoBulk - , _epochPages = getEpochPage - , _epochSlots = getEpochSlot + , _epochPages = getEpochPage epochSlots + , _epochSlots = getEpochSlot epochSlots , _genesisSummary = getGenesisSummary , _genesisPagesTotal = getGenesisPagesTotal , _genesisAddressInfo = getGenesisAddressInfo - , _statsTxs = getStatsTxs + , _statsTxs = getStatsTxs epochSlots } :: ExplorerApiRecord (AsServerT m)) @@ -182,10 +183,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 @@ -213,7 +215,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) @@ -264,8 +266,9 @@ getBlocksPagesTotal mPageSize = do -- for the page size since this is called from __explorer only__. getBlocksLastPage :: ExplorerMode ctx m - => m (Integer, [CBlockEntry]) -getBlocksLastPage = getBlocksPage Nothing (Just defaultPageSizeWord) + => SlotCount -> m (Integer, [CBlockEntry]) +getBlocksLastPage epochSlots = + getBlocksPage epochSlots Nothing (Just defaultPageSizeWord) -- | Get last transactions from the blockchain. @@ -306,12 +309,13 @@ getLastTxs = do -- | Get block summary. getBlockSummary :: ExplorerMode ctx m - => CHash + => SlotCount + -> CHash -> m CBlockSummary -getBlockSummary cHash = do +getBlockSummary epochSlots cHash = do headerHash <- unwrapOrThrow $ fromCHash cHash mainBlund <- getMainBlund headerHash - toBlockSummary mainBlund + toBlockSummary epochSlots mainBlund -- | Get transactions from a block. @@ -643,10 +647,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 @@ -655,7 +660,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] @@ -692,10 +697,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 @@ -711,7 +717,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 @@ -746,11 +752,12 @@ getEpochPage epochIndex mPage = do getStatsTxs :: forall ctx m. ExplorerMode ctx m - => Maybe Word + => 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 1e9bd4290da..f699289deb6 100644 --- a/explorer/src/Pos/Explorer/Web/Transform.hs +++ b/explorer/src/Pos/Explorer/Web/Transform.hs @@ -25,7 +25,7 @@ import Pos.Chain.Block (HasBlockConfiguration) import Pos.Chain.Ssc (HasSscConfiguration) import Pos.Chain.Update (HasUpdateConfiguration) import Pos.Configuration (HasNodeConfiguration) -import Pos.Core (HasConfiguration) +import Pos.Core (HasConfiguration, SlotCount) import Pos.DB.Txp (MempoolExt, MonadTxpLocal (..)) import Pos.Infra.Diffusion.Types (Diffusion) import Pos.Infra.Reporting (MonadReporting (..)) @@ -61,7 +61,7 @@ instance HasConfiguration => instance HasConfiguration => MonadTxpLocal ExplorerProd where txpNormalize pm = lift . lift . txpNormalize pm - txpProcessTx pm txpConfig = lift . lift . txpProcessTx pm txpConfig + txpProcessTx coreConfig txpConfig = lift . lift . txpProcessTx coreConfig txpConfig -- | Use the 'RealMode' instance. -- FIXME instance on a type synonym. @@ -85,26 +85,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 4f57b82501a..2a7145b32d0 100644 --- a/explorer/src/explorer/Main.hs +++ b/explorer/src/explorer/Main.hs @@ -22,8 +22,8 @@ import Pos.Client.CLI (CommonNodeArgs (..), NodeArgs (..), getNodeParams) import qualified Pos.Client.CLI as CLI import Pos.Context (NodeContext (..)) -import Pos.Core (Config (..), epochSlots) -import Pos.Crypto (ProtocolMagic) +import Pos.Core as Core (Config (..), configBlkSecurityParam, + configEpochSlots) import Pos.Explorer.DB (explorerInitDB) import Pos.Explorer.ExtraContext (makeExtraCtx) import Pos.Explorer.Socket (NotifierSettings (..)) @@ -71,18 +71,21 @@ action (ExplorerNodeArgs (cArgs@CommonNodeArgs{..}) ExplorerArgs{..}) = let vssSK = fromJust $ npUserSecret currentParams ^. usVss let sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig currentParams) + let epochSlots = configEpochSlots coreConfig let plugins :: [Diffusion ExplorerProd -> ExplorerProd ()] plugins = - [ explorerPlugin webPort - , notifierPlugin NotifierSettings{ nsPort = notifierPort } + [ explorerPlugin epochSlots webPort + , notifierPlugin epochSlots NotifierSettings {nsPort = notifierPort} , updateTriggerWorker ] - let pm = configProtocolMagic coreConfig - bracketNodeResources currentParams sscParams - (explorerTxpGlobalSettings pm txpConfig) - (explorerInitDB pm epochSlots) $ \nr@NodeResources {..} -> - runExplorerRealMode pm txpConfig nr (runNode pm txpConfig nr plugins) + bracketNodeResources + (configBlkSecurityParam coreConfig) + currentParams + sscParams + (explorerTxpGlobalSettings (configProtocolMagic coreConfig) txpConfig) + (explorerInitDB coreConfig) $ \nr@NodeResources {..} -> + runExplorerRealMode coreConfig txpConfig nr (runNode coreConfig txpConfig nr plugins) where blPath :: Maybe AssetLockPath @@ -93,16 +96,16 @@ action (ExplorerNodeArgs (cArgs@CommonNodeArgs{..}) ExplorerArgs{..}) = runExplorerRealMode :: (HasConfigurations,HasCompileInfo) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> NodeResources ExplorerExtraModifier -> (Diffusion ExplorerProd -> ExplorerProd ()) -> IO () - runExplorerRealMode pm txpConfig nr@NodeResources{..} go = + runExplorerRealMode coreConfig txpConfig nr@NodeResources{..} go = let NodeContext {..} = nrContext extraCtx = makeExtraCtx explorerModeToRealMode = runExplorerProd extraCtx - in runRealMode pm txpConfig nr $ \diffusion -> + in runRealMode coreConfig txpConfig nr $ \diffusion -> explorerModeToRealMode (go (hoistDiffusion (lift . lift) explorerModeToRealMode diffusion)) nodeArgs :: NodeArgs diff --git a/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs b/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs index 8a07bebc9ad..4b0450271f0 100644 --- a/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs +++ b/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs @@ -30,6 +30,7 @@ import Pos.Util (divRoundUp) import Test.Pos.Chain.Block.Arbitrary () import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Core.Dummy (dummyEpochSlots) ---------------------------------------------------------------- @@ -190,7 +191,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 @@ -232,7 +233,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. @@ -240,7 +241,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 @@ -276,6 +277,7 @@ epochSlotUnitSpec = do epochSlotM = runExplorerTestMode testParams extraContext $ getEpochSlot + dummyEpochSlots (EpochIndex 0) 1 @@ -313,6 +315,7 @@ epochPageUnitSpec = do epochPageM = runExplorerTestMode testParams extraContext $ getEpochPage + dummyEpochSlots (EpochIndex 0) Nothing diff --git a/generator/Makefile b/generator/Makefile new file mode 100644 index 00000000000..181e5a331d0 --- /dev/null +++ b/generator/Makefile @@ -0,0 +1,13 @@ +help: ## Print documentation + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +ghcid: ## Run ghcid with the cardano-sl-generator package + ghcid \ + --command "stack ghci cardano-sl-generator --ghci-options=-fno-code" + +ghcid-test: ## Have ghcid run the test suite for the wallet-new-specs on successful recompile + ghcid \ + --command "stack ghci cardano-sl-generator:lib cardano-sl-generator:test:cardano-generator-test --ghci-options=-fobject-code" \ + --test "Main.main" + +.PHONY: ghcid ghcid-test help diff --git a/generator/app/VerificationBench.hs b/generator/app/VerificationBench.hs index 45f2e9a6e4f..a93988baa67 100644 --- a/generator/app/VerificationBench.hs +++ b/generator/app/VerificationBench.hs @@ -19,17 +19,15 @@ import Pos.Binary.Class (decodeFull, serialize) import Pos.Chain.Block (ApplyBlocksException, Block, VerifyBlocksException) import Pos.Chain.Txp (TxpConfiguration (..)) -import Pos.Core (Config (..), configGeneratedSecretsThrow) +import Pos.Core as Core (Config (..), configGeneratedSecretsThrow) import Pos.Core.Chrono (NE, OldestFirst (..), nonEmptyNewestFirst) import Pos.Core.Common (BlockCount (..), unsafeCoinPortionFromDouble) -import Pos.Core.Configuration (genesisBlockVersionData, genesisData, - slotSecurityParam) +import Pos.Core.Configuration (genesisBlockVersionData, genesisData) import Pos.Core.Genesis (FakeAvvmOptions (..), GenesisData (..), GenesisInitializer (..), GenesisProtocolConstants (..), TestnetBalanceOptions (..), gsSecretKeys) import Pos.Core.Slotting (Timestamp (..)) import Pos.Crypto (SecretKey) -import Pos.Crypto.Configuration (ProtocolMagic) import Pos.DB.Block (rollbackBlocks, verifyAndApplyBlocks, verifyBlocksPrefix) import Pos.DB.DB (initNodeDBs) @@ -71,14 +69,14 @@ balance = TestnetBalanceOptions } generateBlocks :: HasConfigurations - => ProtocolMagic + => Core.Config -> [SecretKey] -> TxpConfiguration -> BlockCount -> BlockTestMode (OldestFirst NE Block) -generateBlocks pm secretKeys txpConfig bCount = do +generateBlocks coreConfig secretKeys txpConfig bCount = do g <- liftIO $ newStdGen - bs <- flip evalRandT g $ genBlocks pm txpConfig + bs <- flip evalRandT g $ genBlocks coreConfig txpConfig (BlockGenParams { _bgpSecrets = mkAllSecretsSimple secretKeys , _bgpBlockCount = bCount @@ -89,7 +87,9 @@ generateBlocks pm secretKeys txpConfig bCount = do , _bgpInplaceDB = False , _bgpSkipNoKey = True , _bgpGenStakeholders = gdBootStakeholders genesisData - , _bgpTxpGlobalSettings = txpGlobalSettings pm (TxpConfiguration 200 Set.empty) + , _bgpTxpGlobalSettings = txpGlobalSettings + (configProtocolMagic coreConfig) + (TxpConfiguration 200 Set.empty) }) (maybeToList . fmap fst) return $ OldestFirst $ NE.fromList bs @@ -205,16 +205,15 @@ main = do , _tpGenesisInitializer = genesisInitializer , _tpTxpConfiguration = TxpConfiguration 200 Set.empty } - pm = configProtocolMagic coreConfig secretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow coreConfig runBlockTestMode tp secretKeys $ do -- initialize databasea - initNodeDBs pm slotSecurityParam + initNodeDBs coreConfig bs <- case baBlockCache args of Nothing -> do -- generate blocks and evaluate them to normal form logInfo "Generating blocks" - generateBlocks pm secretKeys txpConfig (baBlockCount args) + generateBlocks coreConfig secretKeys txpConfig (baBlockCount args) Just path -> do fileExists <- liftIO $ doesFileExist path mbs <- if fileExists @@ -224,7 +223,7 @@ main = do Nothing -> do -- generate blocks and evaluate them to normal form logInfo "Generating blocks" - bs <- generateBlocks pm secretKeys txpConfig (baBlockCount args) + bs <- generateBlocks coreConfig secretKeys txpConfig (baBlockCount args) liftIO $ writeBlocks path bs return bs Just bs -> return bs @@ -236,8 +235,8 @@ main = do $ \(idx, blocks) -> do logInfo $ sformat ("Pass: "%int) idx (if baApply args - then validateAndApply pm txpConfig blocks - else validate pm blocks) + then validateAndApply coreConfig txpConfig blocks + else validate coreConfig blocks) let -- drop first three results (if there are more than three results) itimes :: [Float] @@ -266,27 +265,28 @@ main = do validate :: HasConfigurations - => ProtocolMagic + => Core.Config -> OldestFirst NE Block -> BlockTestMode (Microsecond, Maybe (Either VerifyBlocksException ApplyBlocksException)) - validate pm blocks = do + validate coreConfig blocks = do verStart <- realTime - res <- (force . either Left (Right . fst)) <$> verifyBlocksPrefix pm Nothing blocks + res <- (force . either Left (Right . fst)) <$> verifyBlocksPrefix coreConfig Nothing blocks verEnd <- realTime return (verEnd - verStart, either (Just . Left) (const Nothing) res) validateAndApply :: HasConfigurations - => ProtocolMagic + => Core.Config -> TxpConfiguration -> OldestFirst NE Block -> BlockTestMode (Microsecond, Maybe (Either VerifyBlocksException ApplyBlocksException)) - validateAndApply pm txpConfig blocks = do + validateAndApply coreConfig txpConfig blocks = do verStart <- realTime - res <- force <$> verifyAndApplyBlocks pm txpConfig Nothing False blocks + res <- force <$> verifyAndApplyBlocks coreConfig txpConfig Nothing False blocks verEnd <- realTime case res of Left _ -> return () - Right (_, blunds) - -> whenJust (nonEmptyNewestFirst blunds) (rollbackBlocks pm) + Right (_, blunds) -> whenJust + (nonEmptyNewestFirst blunds) + (rollbackBlocks coreConfig) return (verEnd - verStart, either (Just . Right) (const Nothing) res) diff --git a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs index 1f0566c9ade..58858fa4e11 100644 --- a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs +++ b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs @@ -17,11 +17,11 @@ import Pos.AllSecrets (mkAllSecretsSimple) import Pos.Chain.Block (Block, VerifyBlockParams (..), VerifyHeaderParams (..), getBlockHeader, verifyBlock, verifyHeader) -import Pos.Core as Core (Config (..), configGeneratedSecretsThrow) +import Pos.Core as Core (Config (..), configEpochSlots, + configGeneratedSecretsThrow) import Pos.Core.Chrono (NE, OldestFirst (..), nonEmptyNewestFirst) import Pos.Core.Common (BlockCount (..), unsafeCoinPortionFromDouble) -import Pos.Core.Configuration (genesisBlockVersionData, genesisData, - slotSecurityParam) +import Pos.Core.Configuration (genesisBlockVersionData, genesisData) import Pos.Core.Genesis (FakeAvvmOptions (..), GenesisData (..), GenesisInitializer (..), TestnetBalanceOptions (..), gsSecretKeys) @@ -29,7 +29,6 @@ import Pos.Core.Slotting (EpochOrSlot (..), SlotId, Timestamp (..), epochIndexL, getEpochOrSlot) import Pos.Core.Update (BlockVersionData (..)) import Pos.Crypto (SecretKey) -import Pos.Crypto.Configuration (ProtocolMagic (..)) import Pos.DB (getTipHeader) import Pos.DB.Block (rollbackBlocks, verifyAndApplyBlocks, verifyBlocksPrefix) @@ -87,12 +86,12 @@ runBTM tp ctx btm = runEmulation (getTimestamp (_tpStartTime tp)) $ runReaderT b -- | Benchmark which runs `verifyAndApplyBlocks` && `rollbackBlocks`. verifyBlocksBenchmark :: HasConfigurations - => ProtocolMagic + => Core.Config -> [SecretKey] -> TestParams -> BlockTestContext -> Benchmark -verifyBlocksBenchmark !pm !secretKeys !tp !ctx = +verifyBlocksBenchmark !coreConfig !secretKeys !tp !ctx = bgroup "block verification" [ env (runBlockTestMode tp secretKeys (genEnv (BlockCount 100))) $ \ ~(curSlot, blocks) -> bench "verifyAndApplyBlocks" (verifyAndApplyBlocksB curSlot blocks) @@ -104,9 +103,9 @@ verifyBlocksBenchmark !pm !secretKeys !tp !ctx = where genEnv :: BlockCount -> BlockTestMode (Maybe SlotId, OldestFirst NE Block) genEnv bCount = do - initNodeDBs pm slotSecurityParam + initNodeDBs coreConfig g <- liftIO $ newStdGen - bs <- flip evalRandT g $ genBlocks pm (_tpTxpConfiguration tp) + bs <- flip evalRandT g $ genBlocks coreConfig (_tpTxpConfiguration tp) (BlockGenParams { _bgpSecrets = mkAllSecretsSimple secretKeys , _bgpBlockCount = bCount @@ -117,7 +116,9 @@ verifyBlocksBenchmark !pm !secretKeys !tp !ctx = , _bgpInplaceDB = False , _bgpSkipNoKey = True -- TODO: should be False? , _bgpGenStakeholders = gdBootStakeholders genesisData - , _bgpTxpGlobalSettings = txpGlobalSettings pm (_tpTxpConfiguration tp) + , _bgpTxpGlobalSettings = txpGlobalSettings + (configProtocolMagic coreConfig) + (_tpTxpConfiguration tp) }) (maybeToList . fmap fst) let curSlot :: Maybe SlotId @@ -134,10 +135,11 @@ verifyBlocksBenchmark !pm !secretKeys !tp !ctx = nfIO $ runBTM tp ctx $ satisfySlotCheck blocks - $ verifyAndApplyBlocks pm (_tpTxpConfiguration tp) curSlot False blocks >>= \case + $ verifyAndApplyBlocks coreConfig (_tpTxpConfiguration tp) curSlot False blocks >>= \case Left err -> return (Just err) Right (_, blunds) -> do - whenJust (nonEmptyNewestFirst blunds) (rollbackBlocks pm) + whenJust (nonEmptyNewestFirst blunds) + (rollbackBlocks coreConfig) return Nothing verifyBlocksPrefixB @@ -148,16 +150,16 @@ verifyBlocksBenchmark !pm !secretKeys !tp !ctx = nfIO $ runBTM tp ctx $ satisfySlotCheck blocks - $ map fst <$> verifyBlocksPrefix pm curSlot blocks + $ map fst <$> verifyBlocksPrefix coreConfig curSlot blocks -- | Benchmark which runs `verifyHeader` verifyHeaderBenchmark :: HasConfigurations - => ProtocolMagic + => Core.Config -> [SecretKey] -> TestParams -> Benchmark -verifyHeaderBenchmark !pm !secretKeys !tp = env (runBlockTestMode tp secretKeys genEnv) +verifyHeaderBenchmark !coreConfig !secretKeys !tp = env (runBlockTestMode tp secretKeys genEnv) $ \ ~(block, params) -> bgroup "block verification" [ bench "verifyHeader" $ benchHeaderVerification (getBlockHeader block, vbpVerifyHeader params) @@ -166,9 +168,10 @@ verifyHeaderBenchmark !pm !secretKeys !tp = env (runBlockTestMode tp secretKeys ] where + pm = configProtocolMagic coreConfig genEnv :: BlockTestMode (Block, VerifyBlockParams) genEnv = do - initNodeDBs pm slotSecurityParam + initNodeDBs coreConfig g <- liftIO $ newStdGen eos <- getEpochOrSlot <$> getTipHeader let epoch = eos ^. epochIndexL @@ -182,14 +185,17 @@ verifyHeaderBenchmark !pm !secretKeys !tp = env (runBlockTestMode tp secretKeys , _bgpInplaceDB = False , _bgpSkipNoKey = True -- TODO: should be False? , _bgpGenStakeholders = gdBootStakeholders genesisData - , _bgpTxpGlobalSettings = txpGlobalSettings pm (_tpTxpConfiguration tp) + , _bgpTxpGlobalSettings = + txpGlobalSettings pm (_tpTxpConfiguration tp) } leaders <- lrcActionOnEpochReason epoch "genBlock" getLeadersForEpoch mblock <- flip evalRandT g $ do - blockGenCtx <- lift $ mkBlockGenContext blockGenParams + blockGenCtx <- lift $ mkBlockGenContext + (configEpochSlots coreConfig) + blockGenParams tipHeader <- lift $ getTipHeader mapRandT (flip runReaderT blockGenCtx) - $ genBlockNoApply pm (_tpTxpConfiguration tp) eos tipHeader + $ genBlockNoApply coreConfig (_tpTxpConfiguration tp) eos tipHeader let !block = fromMaybe (error "verifyHeaderBench: failed to generate a header") mblock let !verifyHeaderParams = VerifyHeaderParams @@ -211,7 +217,7 @@ verifyHeaderBenchmark !pm !secretKeys !tp = env (runBlockTestMode tp secretKeys nf isVerSuccess $ verifyHeader pm params header benchBlockVerification ~(block, params) = - nf isVerSuccess $ verifyBlock pm params block + nf isVerSuccess $ verifyBlock coreConfig params block runBenchmark :: IO () @@ -231,11 +237,10 @@ runBenchmark = do , _tpGenesisInitializer = genesisInitializer , _tpTxpConfiguration = txpConfig } - pm = configProtocolMagic coreConfig secretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow coreConfig runEmulation startTime $ initBlockTestContext tp secretKeys $ \ctx -> sudoLiftIO $ defaultMainWith config - [ verifyBlocksBenchmark pm secretKeys tp ctx - , verifyHeaderBenchmark pm secretKeys tp + [ verifyBlocksBenchmark coreConfig secretKeys tp ctx + , verifyHeaderBenchmark coreConfig secretKeys tp ] diff --git a/generator/src/Pos/Generator/Block/Logic.hs b/generator/src/Pos/Generator/Block/Logic.hs index c83fcf6267b..43cc468aada 100644 --- a/generator/src/Pos/Generator/Block/Logic.hs +++ b/generator/src/Pos/Generator/Block/Logic.hs @@ -24,9 +24,12 @@ import Pos.AllSecrets (HasAllSecrets (..), unInvSecretsMap) import Pos.Chain.Block (Block, BlockHeader, Blund, mkGenesisBlock) import Pos.Chain.Delegation (ProxySKBlockInfo) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Core (EpochOrSlot (..), SlotId (..), addressHash, - epochIndexL, getEpochOrSlot, getSlotIndex) -import Pos.Crypto (ProtocolMagic, pskDelegatePk) +import Pos.Core as Core (Config (..), EpochOrSlot (..), SlotId (..), + addressHash, configEpochSlots, epochIndexL, + epochOrSlotEnumFromTo, epochOrSlotFromEnum, + epochOrSlotSucc, epochOrSlotToEnum, getEpochOrSlot, + getSlotIndex, localSlotIndexMinBound) +import Pos.Crypto (pskDelegatePk) import Pos.DB.Block (ShouldCallBListener (..), applyBlocksUnsafe, createMainBlockInternal, lrcSingleShot, normalizeMempool, verifyBlocksPrefix) @@ -72,28 +75,31 @@ foldM' combine = go -- injector, for example. genBlocks :: forall g ctx m t . (BlockTxpGenMode g ctx m, Semigroup t, Monoid t) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> BlockGenParams -> (Maybe Blund -> t) -> RandT g m t -genBlocks pm txpConfig params inj = do - ctx <- lift $ mkBlockGenContext @(MempoolExt m) params +genBlocks coreConfig txpConfig params inj = do + ctx <- lift $ mkBlockGenContext @(MempoolExt m) epochSlots params mapRandT (`runReaderT` ctx) genBlocksDo where + epochSlots = configEpochSlots coreConfig genBlocksDo :: RandT g (BlockGenMode (MempoolExt m) m) t 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 -> EpochOrSlot -> RandT g (BlockGenMode (MempoolExt m) m) t - genOneBlock t eos = ((t <>) . inj) <$> genBlock pm txpConfig eos + genOneBlock t eos = ((t <>) . inj) <$> genBlock coreConfig txpConfig eos -- | Generate a 'Block' for the given epoch or slot (geneis block in the formet -- case and main block in the latter case) and do not apply it. @@ -104,22 +110,22 @@ genBlockNoApply , Default (MempoolExt m) , MonadTxpLocal (BlockGenMode (MempoolExt m) m) ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> EpochOrSlot -> BlockHeader -- ^ previoud block header -> BlockGenRandMode (MempoolExt m) g m (Maybe Block) -genBlockNoApply pm txpConfig eos header = do +genBlockNoApply coreConfig txpConfig eos header = do let epoch = eos ^. epochIndexL - lift $ unlessM ((epoch ==) <$> LrcDB.getEpoch) (lrcSingleShot pm epoch) + lift $ unlessM ((epoch ==) <$> LrcDB.getEpoch) (lrcSingleShot coreConfig epoch) -- We need to know leaders to create any block. leaders <- lift $ lrcActionOnEpochReason epoch "genBlock" LrcDB.getLeadersForEpoch case eos of EpochOrSlot (Left _) -> do - let genesisBlock = mkGenesisBlock pm (Right header) epoch leaders + let genesisBlock = mkGenesisBlock (configProtocolMagic coreConfig) (Right header) epoch leaders return $ Just $ Left genesisBlock EpochOrSlot (Right slot@SlotId {..}) -> withCurrentSlot slot $ do - genPayload pm txpConfig slot + genPayload coreConfig txpConfig slot leader <- lift $ maybeThrow (BGInternal "no leader") @@ -149,7 +155,7 @@ genBlockNoApply pm txpConfig eos header = do ProxySKBlockInfo -> BlockGenMode (MempoolExt m) m Block genMainBlock slot proxySkInfo = - createMainBlockInternal pm slot proxySkInfo >>= \case + createMainBlockInternal coreConfig slot proxySkInfo >>= \case Left err -> throwM (BGFailedToCreate err) Right mainBlock -> return $ Right mainBlock @@ -162,18 +168,18 @@ genBlock :: , Default (MempoolExt m) , MonadTxpLocal (BlockGenMode (MempoolExt m) m) ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> EpochOrSlot -> BlockGenRandMode (MempoolExt m) g m (Maybe Blund) -genBlock pm txpConfig eos = do +genBlock coreConfig txpConfig eos = do let epoch = eos ^. epochIndexL tipHeader <- lift DB.getTipHeader - genBlockNoApply pm txpConfig eos tipHeader >>= \case - Just block@Left{} -> - let slot0 = SlotId epoch minBound - in fmap Just $ withCurrentSlot slot0 $ lift $ verifyAndApply (Just slot0) block - Just block@Right {} -> + genBlockNoApply coreConfig txpConfig eos tipHeader >>= \case + Just block@Left{} -> do + let slot0 = SlotId epoch localSlotIndexMinBound + fmap Just $ withCurrentSlot slot0 $ lift $ verifyAndApply (Just slot0) block + Just block@Right {} -> do fmap Just $ lift $ verifyAndApply Nothing block Nothing -> return Nothing where @@ -182,11 +188,15 @@ genBlock pm txpConfig eos = do -> Block -> BlockGenMode (MempoolExt m) m Blund verifyAndApply curSlot block = - verifyBlocksPrefix pm curSlot (one block) >>= \case + verifyBlocksPrefix coreConfig curSlot (one block) >>= \case Left err -> throwM (BGCreatedInvalid err) Right (undos, pollModifier) -> do - let undo = undos ^. _Wrapped . _neHead + let undo = undos ^. _Wrapped . _neHead blund = (block, undo) - applyBlocksUnsafe pm (ShouldCallBListener True) (one blund) (Just pollModifier) - normalizeMempool pm txpConfig + applyBlocksUnsafe + coreConfig + (ShouldCallBListener True) + (one blund) + (Just pollModifier) + normalizeMempool coreConfig txpConfig pure blund diff --git a/generator/src/Pos/Generator/Block/Mode.hs b/generator/src/Pos/Generator/Block/Mode.hs index 1db18ffd8b5..084cba5b768 100644 --- a/generator/src/Pos/Generator/Block/Mode.hs +++ b/generator/src/Pos/Generator/Block/Mode.hs @@ -35,8 +35,8 @@ import Pos.Chain.Update (HasUpdateConfiguration) import Pos.Client.Txp.Addresses (MonadAddresses (..)) import Pos.Configuration (HasNodeConfiguration) import Pos.Core (Address, HasConfiguration, HasPrimaryKey (..), - SlotId (..), Timestamp, epochOrSlotToSlot, getEpochOrSlot, - largestPubKeyAddressBoot) + SlotCount, SlotId (..), Timestamp, epochOrSlotToSlot, + getEpochOrSlot, largestPubKeyAddressBoot) import Pos.Core.Exception (reportFatalError) import Pos.Core.Genesis (GenesisWStakeholders (..)) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), @@ -147,13 +147,12 @@ type BlockGenRandMode ext g m = RandT g (BlockGenMode ext m) -- 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 @@ -173,8 +172,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 {..} @@ -219,10 +218,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 @@ -310,14 +309,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 @@ -327,18 +326,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 7a1245f2a61..ef495f1ae35 100644 --- a/generator/src/Pos/Generator/Block/Payload.hs +++ b/generator/src/Pos/Generator/Block/Payload.hs @@ -28,13 +28,13 @@ import Pos.Chain.Txp (TxpConfiguration, Utxo, execUtxoM, utxoToLookup) import qualified Pos.Chain.Txp as Utxo import Pos.Client.Txp.Util (InputSelectionPolicy (..), TxError (..), createGenericTx, makeMPubKeyTxAddrs) -import Pos.Core (AddrSpendingData (..), Address (..), Coin, - SlotId (..), addressHash, coinToInteger, +import Pos.Core as Core (AddrSpendingData (..), Address (..), Coin, + Config (..), SlotId (..), addressHash, coinToInteger, makePubKeyAddressBoot, unsafeIntegerToCoin) import Pos.Core.Txp (Tx (..), TxAux (..), TxIn (..), TxOut (..), TxOutAux (..)) -import Pos.Crypto (ProtocolMagic, SecretKey, WithHash (..), - fakeSigner, hash, toPublic) +import Pos.Crypto (SecretKey, WithHash (..), fakeSigner, hash, + toPublic) import Pos.DB.Txp (MonadTxpLocal (..), getAllPotentiallyHugeUtxo) import Pos.Generator.Block.Error (BlockGenError (..)) import Pos.Generator.Block.Mode (BlockGenMode, BlockGenRandMode, @@ -121,10 +121,10 @@ makeLenses ''GenTxData genTxPayload :: forall ext g m . (RandomGen g, MonadBlockGenBase m, MonadTxpLocal (BlockGenMode ext m)) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> BlockGenRandMode ext g m () -genTxPayload pm txpConfig = do +genTxPayload coreConfig txpConfig = do invAddrSpendingData <- unInvAddrSpendingData <$> view (blockGenParams . asSpendingData) -- We only leave outputs we have secret keys related to. Tx @@ -213,18 +213,21 @@ genTxPayload pm txpConfig = do getSigner addr = note (SafeSignerNotFound addr) $ HM.lookup addr signers - makeTestTx i o = makeMPubKeyTxAddrs pm getSigner i o + makeTestTx i o = makeMPubKeyTxAddrs (configProtocolMagic coreConfig) + getSigner + i + o groupedInputs = OptimizeForSecurity eTx <- lift . lift $ - createGenericTx pm mempty makeTestTx groupedInputs ownUtxo txOutAuxs changeAddrData + createGenericTx coreConfig 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 txpConfig (txId, txAux) + res <- lift . lift $ txpProcessTx coreConfig txpConfig (txId, txAux) case res of Left e -> error $ "genTransaction@txProcessTransaction: got left: " <> pretty e Right _ -> do @@ -248,8 +251,8 @@ genTxPayload pm txpConfig = do genPayload :: forall ext g m . (RandomGen g, MonadBlockGenBase m, MonadTxpLocal (BlockGenMode ext m)) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> SlotId -> BlockGenRandMode ext g m () -genPayload pm txpConfig _ = genTxPayload pm txpConfig +genPayload coreConfig txpConfig _ = genTxPayload coreConfig txpConfig diff --git a/generator/src/Pos/Generator/BlockEvent.hs b/generator/src/Pos/Generator/BlockEvent.hs index 0f2c0e648ef..57c74f94ae7 100644 --- a/generator/src/Pos/Generator/BlockEvent.hs +++ b/generator/src/Pos/Generator/BlockEvent.hs @@ -62,10 +62,10 @@ import Serokell.Util (listJson) import Pos.AllSecrets (AllSecrets) import Pos.Chain.Block (Blund, HeaderHash, headerHash, prevBlockL) import Pos.Chain.Txp (TxpConfiguration) +import Pos.Core as Core (Config) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst, toOldestFirst, _OldestFirst) import Pos.Core.Genesis (GenesisWStakeholders) -import Pos.Crypto (ProtocolMagic) import Pos.Crypto.Hashing (hashHexF) import Pos.DB.Txp (TxpGlobalSettings) import Pos.Generator.Block (BlockGenParams (..), BlockTxpGenMode, @@ -157,25 +157,25 @@ flattenBlockchainTree prePath tree = do genBlocksInForest :: BlockTxpGenMode g ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> AllSecrets -> GenesisWStakeholders -> BlockchainForest BlockDesc -> RandT g m (BlockchainForest Blund) -genBlocksInForest pm txpConfig secrets bootStakeholders = +genBlocksInForest coreConfig txpConfig secrets bootStakeholders = traverse $ mapRandT withClonedGState . - genBlocksInTree pm txpConfig secrets bootStakeholders + genBlocksInTree coreConfig txpConfig secrets bootStakeholders genBlocksInTree :: BlockTxpGenMode g ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> AllSecrets -> GenesisWStakeholders -> BlockchainTree BlockDesc -> RandT g m (BlockchainTree Blund) -genBlocksInTree pm txpConfig secrets bootStakeholders blockchainTree = do +genBlocksInTree coreConfig txpConfig secrets bootStakeholders blockchainTree = do txpSettings <- view (lensOf' @TxpGlobalSettings) let BlockchainTree blockDesc blockchainForest = blockchainTree txGenParams = case blockDesc of @@ -190,28 +190,28 @@ genBlocksInTree pm txpConfig secrets bootStakeholders blockchainTree = do , _bgpSkipNoKey = False , _bgpTxpGlobalSettings = txpSettings } - blocks <- genBlocks pm txpConfig blockGenParams maybeToList + blocks <- genBlocks coreConfig txpConfig 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 txpConfig secrets bootStakeholders blockchainForest + forestBlocks <- genBlocksInForest coreConfig txpConfig secrets bootStakeholders blockchainForest return $ BlockchainTree block forestBlocks -- Precondition: paths in the structure are non-empty. genBlocksInStructure :: ( BlockTxpGenMode g ctx m , Functor t, Foldable t) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> AllSecrets -> GenesisWStakeholders -> Map Path BlockDesc -> t Path -> RandT g m (t Blund) -genBlocksInStructure pm txpConfig secrets bootStakeholders annotations s = do +genBlocksInStructure coreConfig txpConfig secrets bootStakeholders annotations s = do let getAnnotation :: Path -> BlockDesc getAnnotation path = @@ -221,7 +221,7 @@ genBlocksInStructure pm txpConfig secrets bootStakeholders annotations s = do descForest :: BlockchainForest BlockDesc descForest = buildBlockchainForest BlockDescDefault paths blockForest :: BlockchainForest Blund <- - genBlocksInForest pm txpConfig secrets bootStakeholders descForest + genBlocksInForest coreConfig txpConfig 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 dea0e68525d..a604d1d8070 100644 --- a/generator/src/Pos/Generator/BlockEvent/DSL.hs +++ b/generator/src/Pos/Generator/BlockEvent/DSL.hs @@ -35,10 +35,10 @@ import qualified Data.Map as Map import Pos.AllSecrets (AllSecrets) import Pos.Chain.Txp (TxpConfiguration) +import Pos.Core as Core (Config) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toOldestFirst, _NewestFirst) import Pos.Core.Genesis (GenesisWStakeholders) -import Pos.Crypto (ProtocolMagic) import Pos.Generator.Block (BlockTxpGenMode, MonadBlockGen) import Pos.Generator.BlockEvent (BlockApplyResult (..), BlockDesc (..), BlockEvent' (..), BlockEventApply' (..), @@ -117,15 +117,15 @@ snapshotEq snapshotId = emitEvent $ runBlockEventGenT :: BlockTxpGenMode g ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> AllSecrets -> GenesisWStakeholders -> BlockEventGenT g m () -> RandT g m BlockScenario -runBlockEventGenT pm txpConfig secrets genStakeholders m = do +runBlockEventGenT coreConfig txpConfig secrets genStakeholders m = do (annotations, preBlockScenario) <- runBlockEventGenT' m - genBlocksInStructure pm txpConfig secrets genStakeholders annotations preBlockScenario + genBlocksInStructure coreConfig txpConfig 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 bb28d398de4..4aa32d6b9fa 100644 --- a/generator/src/Test/Pos/Block/Logic/Event.hs +++ b/generator/src/Test/Pos/Block/Logic/Event.hs @@ -22,7 +22,6 @@ import qualified GHC.Exts as IL import Pos.Chain.Block (Blund, HeaderHash) import Pos.Chain.Txp (TxpConfiguration) import Pos.Core.Chrono (NE, NewestFirst, OldestFirst) -import Pos.Core.Configuration (HasConfiguration) import Pos.Core.Exception (CardanoFatalError (..)) import Pos.Core.Slotting (EpochOrSlot (..), SlotId, getEpochOrSlot) import Pos.DB.Block (BlockLrcMode, rollbackBlocks, @@ -40,7 +39,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.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Core.Dummy (dummyConfig) data SnapshotMissingEx = SnapshotMissingEx SnapshotId deriving (Show) @@ -60,8 +59,7 @@ data BlockEventResult | BlockEventDbChanged DbNotEquivalentToSnapshot verifyAndApplyBlocks' :: - ( HasConfiguration - , BlockLrcMode BlockTestContext m + ( BlockLrcMode BlockTestContext m , MonadTxpLocal m ) => TxpConfiguration @@ -81,10 +79,9 @@ verifyAndApplyBlocks' txpConfig blunds = do ss -> Just $ maximum ss satisfySlotCheck blocks $ do _ :: (HeaderHash, NewestFirst [] Blund) <- eitherToThrow =<< - verifyAndApplyBlocks dummyProtocolMagic txpConfig curSlot True blocks + verifyAndApplyBlocks dummyConfig txpConfig curSlot True blocks return () - where - blocks = fst <$> blunds + where blocks = fst <$> blunds -- | Execute a single block event. runBlockEvent :: @@ -107,7 +104,7 @@ runBlockEvent txpConfig (BlkEvApply ev) = BlockApplyFailure -> BlockEventFailure (IsExpected True) e runBlockEvent _ (BlkEvRollback ev) = - (onSuccess <$ rollbackBlocks dummyProtocolMagic (ev ^. berInput)) + (onSuccess <$ rollbackBlocks dummyConfig (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 1d6b7d1d29d..e18c4be9dd2 100644 --- a/generator/src/Test/Pos/Block/Logic/Mode.hs +++ b/generator/src/Test/Pos/Block/Logic/Mode.hs @@ -64,9 +64,9 @@ import Pos.Chain.Delegation (DelegationVar, HasDlgConfiguration) import Pos.Chain.Ssc (SscMemTag, SscState) import Pos.Chain.Txp (TxpConfiguration (..)) import Pos.Core as Core (Config (..), CoreConfiguration (..), - GenesisConfiguration (..), HasConfiguration, - HasProtocolConstants, SlotId, Timestamp (..), - configGeneratedSecretsThrow, epochSlots, withGenesisSpec) + GenesisConfiguration (..), HasConfiguration, SlotId, + Timestamp (..), configGeneratedSecretsThrow, + withGenesisSpec) import Pos.Core.Conc (currentTime) import Pos.Core.Configuration (HasGenesisBlockVersionData, withGenesisBlockVersionData) @@ -121,6 +121,7 @@ import Test.Pos.Block.Logic.Emulation (Emulation (..), runEmulation, import Test.Pos.Configuration (defaultTestBlockVersionData, defaultTestConf, defaultTestGenesisSpec) import Test.Pos.Core.Arbitrary () +import Test.Pos.Core.Dummy (dummyConfig, dummyEpochSlots) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) ---------------------------------------------------------------------------- @@ -182,10 +183,9 @@ withTestParams TestParams {..} = withGenesisSpec _tpStartTime coreConfiguration 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 } @@ -263,7 +263,7 @@ initBlockTestContext tp@TestParams {..} genesisSecretKeys callback = do (futureLrcCtx, putLrcCtx) <- newInitFuture "lrcCtx" (futureSlottingVar, putSlottingVar) <- newInitFuture "slottingVar" systemStart <- Timestamp <$> currentTime - slottingState <- mkSimpleSlottingStateVar + slottingState <- mkSimpleSlottingStateVar dummyEpochSlots let initCtx = TestInitModeContext dbPureVar @@ -272,15 +272,15 @@ initBlockTestContext tp@TestParams {..} genesisSecretKeys callback = do systemStart futureLrcCtx initBlockTestContextDo = do - initNodeDBs dummyProtocolMagic epochSlots + initNodeDBs dummyConfig _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 _tpTxpConfiguration @@ -386,9 +386,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 @@ -487,23 +485,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 @@ -524,7 +525,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 3f29322d5e6..d9c37ab2240 100644 --- a/generator/src/Test/Pos/Block/Logic/Util.hs +++ b/generator/src/Test/Pos/Block/Logic/Util.hs @@ -27,18 +27,20 @@ import Test.QuickCheck.Monadic (PropertyM, pick) import Pos.AllSecrets (AllSecrets, HasAllSecrets (..), allSecrets) import Pos.Chain.Block (Block, Blund) import Pos.Chain.Txp (TxpConfiguration (..)) -import Pos.Core (BlockCount, HasGenesisData, HasProtocolConstants, - SlotId (..), epochIndexL, genesisData) +import Pos.Core (BlockCount, HasGenesisData, SlotId (..), epochIndexL, + genesisData, localSlotIndexMinBound) import Pos.Core.Chrono (NE, OldestFirst (..)) import Pos.Core.Genesis (GenesisData (..)) -import Pos.Crypto (ProtocolMagic) import Pos.DB.Txp (MempoolExt, MonadTxpLocal, TxpGlobalSettings, txpGlobalSettings) import Pos.Generator.Block (BlockGenMode, BlockGenParams (..), MonadBlockGenInit, genBlocks, tgpTxCountRange) import Pos.Util (HasLens', _neLast) + import Test.Pos.Block.Logic.Mode (BlockProperty, BlockTestContext, btcSlotIdL) +import Test.Pos.Core.Dummy (dummyConfig) +import Test.Pos.Crypto.Dummy (dummyProtocolMagic) -- | Wrapper for 'bpGenBlocks' to clarify the meaning of the argument. newtype EnableTxPayload = EnableTxPayload Bool @@ -55,12 +57,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 = @@ -73,7 +74,9 @@ genBlockGenParams pm blkCnt (EnableTxPayload enableTxPayload) (InplaceDB inplace , _bgpInplaceDB = inplaceDB , _bgpGenStakeholders = genStakeholders , _bgpSkipNoKey = False - , _bgpTxpGlobalSettings = txpGlobalSettings pm (TxpConfiguration 200 Set.empty) + , _bgpTxpGlobalSettings = txpGlobalSettings + dummyProtocolMagic + (TxpConfiguration 200 Set.empty) } pick $ sized genBlockGenParamsF @@ -88,16 +91,15 @@ bpGenBlocks , MonadTxpLocal (BlockGenMode (MempoolExt m) m) , HasAllSecrets ctx ) - => ProtocolMagic - -> TxpConfiguration + => TxpConfiguration -> Maybe BlockCount -> EnableTxPayload -> InplaceDB -> PropertyM m (OldestFirst [] Blund) -bpGenBlocks pm txpConfig blkCnt enableTxPayload inplaceDB = do - params <- genBlockGenParams pm blkCnt enableTxPayload inplaceDB +bpGenBlocks txpConfig blkCnt enableTxPayload inplaceDB = do + params <- genBlockGenParams blkCnt enableTxPayload inplaceDB g <- pick $ MkGen $ \qc _ -> qc - lift $ OldestFirst <$> evalRandT (genBlocks pm txpConfig params maybeToList) g + lift $ OldestFirst <$> evalRandT (genBlocks dummyConfig txpConfig params maybeToList) g -- | A version of 'bpGenBlocks' which generates exactly one -- block. Allows one to avoid unsafe functions sometimes. @@ -108,13 +110,12 @@ bpGenBlock , HasAllSecrets ctx , Default (MempoolExt m) ) - => ProtocolMagic - -> TxpConfiguration + => TxpConfiguration -> EnableTxPayload -> InplaceDB -> PropertyM m Blund -- 'unsafeHead' is safe because we create exactly 1 block -bpGenBlock pm txpConfig = fmap (List.head . toList) ... bpGenBlocks pm txpConfig (Just 1) +bpGenBlock txpConfig = fmap (List.head . toList) ... bpGenBlocks txpConfig (Just 1) getAllSecrets :: (MonadReader ctx m, HasAllSecrets ctx) => m AllSecrets getAllSecrets = view allSecrets @@ -133,10 +134,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 685af095fc7..d40471d01eb 100644 --- a/generator/test/Test/Pos/Binary/CommunicationSpec.hs +++ b/generator/test/Test/Pos/Binary/CommunicationSpec.hs @@ -23,16 +23,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 (TxpConfiguration 200 Set.empty) (EnableTxPayload True) (InplaceDB True) + (block, _) <- bpGenBlock (TxpConfiguration 200 Set.empty) (EnableTxPayload True) (InplaceDB True) let sb = Serialized $ serialize' block assert $ serializeMsgSerializedBlock (MsgSerializedBlock sb) == serialize' (MsgBlock block) prop descNoBlock $ blockPropertyTestable $ \_ -> do @@ -49,11 +47,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 (TxpConfiguration 200 Set.empty) (EnableTxPayload True) (InplaceDB True) + (block, _) <- bpGenBlock (TxpConfiguration 200 Set.empty) (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 6480f0c6aa7..e7a7300f505 100644 --- a/generator/test/Test/Pos/Block/Logic/CreationSpec.hs +++ b/generator/test/Test/Pos/Block/Logic/CreationSpec.hs @@ -22,9 +22,8 @@ import Pos.Chain.Delegation (DlgPayload, ProxySKBlockInfo) import Pos.Chain.Ssc (defaultSscPayload) import Pos.Chain.Update (HasUpdateConfiguration) import qualified Pos.Communication () -import Pos.Core (HasConfiguration, SlotId (..), blkSecurityParam, - genesisBlockVersionData, pcEpochSlots, protocolConstants, - unsafeMkLocalSlotIndexExplicit) +import Pos.Core (SlotId (..), genesisBlockVersionData, + localSlotIndexMinBound, unsafeMkLocalSlotIndex) import Pos.Core.Ssc (SscPayload (..), mkVssCertificatesMapLossy) import Pos.Core.Txp (TxAux) import Pos.Core.Update (BlockVersionData (..), UpdatePayload (..)) @@ -38,6 +37,8 @@ import Test.Pos.Chain.Ssc.Arbitrary (commitmentMapEpochGen, import Test.Pos.Configuration (withDefConfiguration, withDefUpdateConfiguration) import Test.Pos.Core.Arbitrary.Txp (GoodTx, goodTxToTxAux) +import Test.Pos.Core.Dummy (dummyConfig, dummyEpochSlots, dummyK, + dummyProtocolConstants) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck (SmallGenerator (..), makeSmall) @@ -107,8 +108,8 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ in counterexample ("Tested with block size limit: " <> show s) $ leftToCounter blk2 (const True) where - defSscPld :: HasConfiguration => SlotId -> SscPayload - defSscPld sId = defaultSscPayload $ siSlot sId + defSscPld :: SlotId -> SscPayload + defSscPld sId = defaultSscPayload dummyK $ siSlot sId infLimit = convertUnit @Gigabyte @Byte 1 @@ -116,7 +117,7 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ leftToCounter x c = either (\t -> counterexample (toString t) False) (property . c) x emptyBlk - :: (HasConfiguration, HasUpdateConfiguration, Testable p) + :: (HasUpdateConfiguration, Testable p) => (Either Text MainBlock -> p) -> Property emptyBlk foo = @@ -128,7 +129,7 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ goodTxToTxAux . getSmallGenerator <$> (arbitrary :: Gen (SmallGenerator GoodTx)) noSscBlock - :: (HasConfiguration, HasUpdateConfiguration) + :: HasUpdateConfiguration => Byte -> BlockHeader -> [TxAux] @@ -137,13 +138,12 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ -> SecretKey -> Either Text MainBlock noSscBlock limit prevHeader txs proxyCerts updatePayload sk = - let neutralSId = SlotId 0 - (unsafeMkLocalSlotIndexExplicit (pcEpochSlots protocolConstants) $ fromIntegral $ blkSecurityParam * 2) + let neutralSId = SlotId 0 (unsafeMkLocalSlotIndex dummyEpochSlots $ fromIntegral $ dummyK * 2) in producePureBlock limit prevHeader txs Nothing neutralSId proxyCerts (defSscPld neutralSId) updatePayload sk producePureBlock - :: (HasConfiguration, HasUpdateConfiguration) + :: HasUpdateConfiguration => Byte -> BlockHeader -> [TxAux] @@ -155,19 +155,19 @@ spec = withDefConfiguration $ \_ -> withDefUpdateConfiguration $ -> SecretKey -> Either Text MainBlock producePureBlock limit prev txs psk slot dlgPay sscPay usPay sk = - createMainBlockPure dummyProtocolMagic limit prev psk slot sk $ + createMainBlockPure dummyConfig limit prev psk slot sk $ RawPayload txs sscPay dlgPay usPay -validSscPayloadGen :: HasConfiguration => Gen (SscPayload, SlotId) +validSscPayloadGen :: Gen (SscPayload, SlotId) validSscPayloadGen = do vssCerts <- makeSmall $ fmap mkVssCertificatesMapLossy $ listOf $ - vssCertificateEpochGen dummyProtocolMagic protocolConstants 0 - let mkSlot i = SlotId 0 (unsafeMkLocalSlotIndexExplicit (pcEpochSlots protocolConstants) (fromIntegral i)) + 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 minBound) + pure (CommitmentsPayload commMap vssCerts , SlotId 0 localSlotIndexMinBound) , do openingsMap <- makeSmall arbitrary - pure (OpeningsPayload openingsMap vssCerts, mkSlot (4 * blkSecurityParam + 1)) + pure (OpeningsPayload openingsMap vssCerts, mkSlot (4 * dummyK + 1)) , do sharesMap <- makeSmall arbitrary - pure (SharesPayload sharesMap vssCerts, mkSlot (8 * blkSecurityParam)) - , pure (CertificatesPayload vssCerts, mkSlot (7 * blkSecurityParam)) + 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 c24ce40fe7a..be9c4022ce7 100644 --- a/generator/test/Test/Pos/Block/Logic/VarSpec.hs +++ b/generator/test/Test/Pos/Block/Logic/VarSpec.hs @@ -24,7 +24,7 @@ import Test.QuickCheck.Random (QCGen) import Pos.Chain.Block (Blund, headerHash) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Core (HasConfiguration, blkSecurityParam, epochSlots, +import Pos.Core (HasConfiguration, ProtocolConstants (..), genesisData) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), nonEmptyNewestFirst, nonEmptyOldestFirst, @@ -51,7 +51,8 @@ import Test.Pos.Block.Logic.Util (EnableTxPayload (..), import Test.Pos.Block.Property (blockPropertySpec) import Test.Pos.Configuration (HasStaticConfigurations, withStaticConfigurations) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Core.Dummy (dummyConfig, dummyEpochSlots, dummyK, + dummyProtocolConstants) import Test.Pos.Util.QuickCheck.Property (splitIntoChunks, stopProperty) @@ -100,12 +101,10 @@ verifyEmptyMainBlock :: HasConfigurations => TxpConfiguration -> BlockProperty () verifyEmptyMainBlock txpConfig = do - emptyBlock <- fst <$> bpGenBlock dummyProtocolMagic - txpConfig - (EnableTxPayload False) - (InplaceDB False) - curSlot <- getCurrentSlot - whenLeftM (lift $ verifyBlocksPrefix dummyProtocolMagic curSlot (one emptyBlock)) + emptyBlock <- fst + <$> bpGenBlock txpConfig (EnableTxPayload False) (InplaceDB False) + curSlot <- getCurrentSlot dummyEpochSlots + whenLeftM (lift $ verifyBlocksPrefix dummyConfig curSlot (one emptyBlock)) $ stopProperty . pretty @@ -115,11 +114,10 @@ verifyValidBlocks -> BlockProperty () verifyValidBlocks txpConfig = do bpGoToArbitraryState - blocks <- map fst . toList <$> bpGenBlocks dummyProtocolMagic - txpConfig - Nothing - (EnableTxPayload True) - (InplaceDB False) + blocks <- map fst . toList <$> bpGenBlocks txpConfig + Nothing + (EnableTxPayload True) + (InplaceDB False) pre (not $ null blocks) let blocksToVerify = OldestFirst $ case blocks of -- impossible because of precondition (see 'pre' above) @@ -129,7 +127,7 @@ verifyValidBlocks txpConfig = do in block0 :| otherBlocks' verRes <- lift $ satisfySlotCheck blocksToVerify $ verifyBlocksPrefix - dummyProtocolMagic + dummyConfig Nothing blocksToVerify whenLeft verRes $ stopProperty . pretty @@ -151,7 +149,7 @@ verifyAndApplyBlocksSpec txpConfig = satisfySlotCheck blocks $ -- we don't check current SlotId, because the applier is run twice -- and the check will fail the verification - whenLeftM (verifyAndApplyBlocks dummyProtocolMagic txpConfig Nothing True blocks) throwM + whenLeftM (verifyAndApplyBlocks dummyConfig txpConfig Nothing True blocks) throwM applyByOneOrAllAtOnceDesc = "verifying and applying blocks one by one leads " <> "to the same GState as verifying and applying them all at once " <> @@ -185,8 +183,7 @@ applyByOneOrAllAtOnce -> BlockProperty () applyByOneOrAllAtOnce txpConfig applier = do bpGoToArbitraryState - blunds <- getOldestFirst <$> bpGenBlocks dummyProtocolMagic - txpConfig + blunds <- getOldestFirst <$> bpGenBlocks txpConfig Nothing (EnableTxPayload True) (InplaceDB False) @@ -251,12 +248,12 @@ blockEventSuccessSpec txpConfig = 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) @@ -265,7 +262,7 @@ genSuccessWithForks = do generateFork basePath rollbackFork = do let forkLen = length rollbackFork - wiggleRoom = fromIntegral blkSecurityParam - forkLen + wiggleRoom = fromIntegral dummyK - forkLen stopFork <- byChance (if forkLen > 0 then 0.1 else 0) if stopFork then whenJust (nonEmptyNewestFirst rollbackFork) $ @@ -274,7 +271,7 @@ genSuccessWithForks = 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) @@ -305,7 +302,7 @@ blockPropertyScenarioGen txpConfig m = do allSecrets <- getAllSecrets let genStakeholders = gdBootStakeholders genesisData g <- pick $ MkGen $ \qc _ -> qc - lift $ flip evalRandT g $ runBlockEventGenT dummyProtocolMagic + lift $ flip evalRandT g $ runBlockEventGenT dummyConfig txpConfig allSecrets genStakeholders @@ -373,7 +370,7 @@ applyThroughEpochProp txpConfig 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 $ @@ -409,10 +406,10 @@ singleForkProp txpConfig fd = do data ForkDepth = ForkShort | ForkMedium | ForkDeep -genSingleFork :: forall g m. (HasConfigurations, RandomGen g, Monad 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 diff --git a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs index f6e812d62fd..afe098c4889 100644 --- a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs +++ b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs @@ -27,8 +27,8 @@ import Pos.Chain.Block (mainBlockTxPayload) import qualified Pos.Chain.Lrc as Lrc import Pos.Chain.Txp (TxpConfiguration (..)) import Pos.Core as Core (Coin, Config (..), EpochIndex, StakeholderId, - addressHash, blkSecurityParam, coinF, - configGeneratedSecretsThrow, epochSlots, genesisData) + addressHash, coinF, configBlkSecurityParam, + configGeneratedSecretsThrow, genesisData) import Pos.Core.Genesis (GeneratedSecrets, GenesisData (..), GenesisInitializer (..), TestnetBalanceOptions (..), gsSecretKeysPoor, gsSecretKeysRich) @@ -49,7 +49,7 @@ import Test.Pos.Block.Logic.Util (EnableTxPayload (..), import Test.Pos.Block.Property (blockPropertySpec) import Test.Pos.Configuration (defaultTestBlockVersionData, withStaticConfigurations) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Core.Dummy (dummyConfig, dummyEpochSlots, dummyK) import Test.Pos.Util.QuickCheck (maybeStopProperty, stopProperty) @@ -129,7 +129,7 @@ lrcCorrectnessProp :: HasConfigurations -> Core.Config -> BlockProperty () lrcCorrectnessProp txpConfig coreConfig = do - let k = blkSecurityParam + let k = configBlkSecurityParam coreConfig -- 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 @@ -137,8 +137,7 @@ lrcCorrectnessProp txpConfig coreConfig = do -- 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 - txpConfig + () <$ bpGenBlocks txpConfig (Just blkCount0) (EnableTxPayload False) (InplaceDB True) @@ -154,12 +153,11 @@ lrcCorrectnessProp txpConfig coreConfig = do -- 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 - txpConfig + () <$ bpGenBlocks txpConfig (Just blkCount1) (EnableTxPayload False) (InplaceDB True) - lift $ Lrc.lrcSingleShot dummyProtocolMagic 1 + lift $ Lrc.lrcSingleShot dummyConfig 1 leaders1 <- maybeStopProperty "No leaders for epoch#1!" =<< lift (LrcDB.getLeadersForEpoch 1) -- Here we use 'genesisSeed' (which is the seed for the 0-th @@ -171,7 +169,7 @@ lrcCorrectnessProp txpConfig coreConfig = 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% @@ -254,12 +252,11 @@ genAndApplyBlockFixedTxs :: HasConfigurations -> BlockProperty () genAndApplyBlockFixedTxs txpConfig txs = do let txPayload = mkTxPayload txs - emptyBlund <- bpGenBlock dummyProtocolMagic - txpConfig + emptyBlund <- bpGenBlock txpConfig (EnableTxPayload False) (InplaceDB False) let blund = emptyBlund & _1 . _Right . mainBlockTxPayload .~ txPayload - lift $ applyBlocksUnsafe dummyProtocolMagic + lift $ applyBlocksUnsafe dummyConfig (ShouldCallBListener False) (one blund) Nothing @@ -291,18 +288,16 @@ lessThanKAfterCrucialProp => TxpConfiguration -> BlockProperty () lessThanKAfterCrucialProp txpConfig = 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 - txpConfig + let shouldSucceed = inLast2K >= dummyK + () <$ bpGenBlocks txpConfig (Just toGenerate) (EnableTxPayload False) (InplaceDB True) @@ -311,7 +306,7 @@ lessThanKAfterCrucialProp txpConfig = do " 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 + lift (try $ Lrc.lrcSingleShot dummyConfig 1) >>= \case Left Lrc.UnknownBlocksForLrc | shouldSucceed -> stopProperty unexpectedFailMsg | otherwise -> pass diff --git a/infra/Makefile b/infra/Makefile new file mode 100644 index 00000000000..95703062c49 --- /dev/null +++ b/infra/Makefile @@ -0,0 +1,13 @@ +help: ## Print documentation + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +ghcid: ## Run ghcid with the cardano-sl-infra package + ghcid \ + --command "stack ghci cardano-sl-infra --ghci-options=-fno-code" + +ghcid-test: ## Have ghcid run the test suite for the wallet-new-specs on successful recompile + ghcid \ + --command "stack ghci cardano-sl-infra:lib cardano-sl-infra:test:test --ghci-options=-fobject-code" \ + --test "Main.main" + +.PHONY: ghcid ghcid-test help diff --git a/infra/src/Pos/Infra/DHT/Workers.hs b/infra/src/Pos/Infra/DHT/Workers.hs index b40a355e93d..5191d7be72c 100644 --- a/infra/src/Pos/Infra/DHT/Workers.hs +++ b/infra/src/Pos/Infra/DHT/Workers.hs @@ -14,6 +14,7 @@ import Network.Kademlia (takeSnapshot) import UnliftIO (MonadUnliftIO) import Pos.Binary.Class (serialize) +import Pos.Core (BlockCount, kEpochSlots) import Pos.Core.Slotting (MonadSlots, flattenSlotId, slotIdF) import Pos.Infra.Binary.DHTModel () import Pos.Infra.DHT.Constants (kademliaDumpInterval) @@ -39,17 +40,19 @@ type DhtWorkMode ctx m = dhtWorkers :: DhtWorkMode ctx m - => KademliaDHTInstance -> [Diffusion m -> m ()] -dhtWorkers kademliaInst@KademliaDHTInstance {..} = - [ dumpKademliaStateWorker kademliaInst ] + => BlockCount + -> KademliaDHTInstance -> [Diffusion m -> m ()] +dhtWorkers k kademliaInst@KademliaDHTInstance {..} = + [ dumpKademliaStateWorker k kademliaInst ] dumpKademliaStateWorker :: DhtWorkMode ctx m - => KademliaDHTInstance + => BlockCount + -> KademliaDHTInstance -> Diffusion m -> m () -dumpKademliaStateWorker kademliaInst = \_ -> onNewSlot onsp $ \slotId -> - when (isTimeToDump slotId) $ recoveryCommGuard "dump kademlia state" $ do +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 @@ -58,5 +61,6 @@ dumpKademliaStateWorker kademliaInst = \_ -> onNewSlot onsp $ \slotId -> Just fp -> liftIO . BSL.writeFile fp . serialize $ snapshot Nothing -> return () where + epochSlots = kEpochSlots k onsp = defaultOnNewSlotParams - isTimeToDump slotId = flattenSlotId slotId `mod` kademliaDumpInterval == 0 + isTimeToDump slotId = flattenSlotId epochSlots slotId `mod` kademliaDumpInterval == 0 diff --git a/infra/src/Pos/Infra/Recovery/Info.hs b/infra/src/Pos/Infra/Recovery/Info.hs index 21f1a5f64f7..a6ba2de4b26 100644 --- a/infra/src/Pos/Infra/Recovery/Info.hs +++ b/infra/src/Pos/Infra/Recovery/Info.hs @@ -10,7 +10,6 @@ module Pos.Infra.Recovery.Info , MonadRecoveryInfo , getSyncStatus , recoveryInProgress - , getSyncStatusK , recoveryCommGuard , needTriggerRecovery ) where @@ -22,8 +21,9 @@ import Control.Monad.Except (runExceptT, throwError) import Formatting (bprint, build, sformat, stext, (%)) import qualified Formatting.Buildable -import Pos.Core (SlotCount, SlotId, epochOrSlotG, epochOrSlotToSlot, - flattenSlotId, slotIdF, slotSecurityParam) +import Pos.Core (BlockCount, SlotCount, SlotId, epochOrSlotG, + epochOrSlotToSlot, flattenSlotId, kEpochSlots, + kSlotSecurityParam, slotIdF) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead) import Pos.Infra.Recovery.Types (RecoveryHeader, RecoveryHeaderTag) @@ -92,13 +92,13 @@ type MonadRecoveryInfo ctx m = -- place. See 'SyncStatus' for details. -- Implementation must check conditions in the same order as they -- are enumerated in 'SyncStatus'. -getSyncStatus :: MonadRecoveryInfo ctx m => SlotCount -> m SyncStatus -getSyncStatus lagBehindParam = +getSyncStatus :: MonadRecoveryInfo ctx m => SlotCount -> SlotCount -> m SyncStatus +getSyncStatus epochSlots lagBehindParam = fmap convertRes . runExceptT $ do recoveryIsInProgress >>= \case False -> pass True -> throwError SSDoingRecovery - curSlotId <- note SSUnknownSlot =<< getCurrentSlot + curSlotId <- note SSUnknownSlot =<< getCurrentSlot epochSlots tipHeader <- lift DB.getTipHeader let curSlot = CurrentSlot curSlotId let tipSlot@(TipSlot tipSlotId) = TipSlot $ @@ -106,7 +106,7 @@ getSyncStatus lagBehindParam = unless (tipSlotId <= curSlotId) $ throwError $ SSInFuture tipSlot curSlot - let slotDiff = flattenSlotId curSlotId - flattenSlotId tipSlotId + let slotDiff = flattenSlotId epochSlots curSlotId - flattenSlotId epochSlots tipSlotId unless (slotDiff < fromIntegral lagBehindParam) $ throwError $ SSLagBehind tipSlot curSlot @@ -120,33 +120,19 @@ getSyncStatus lagBehindParam = -- | Returns if our 'SyncStatus' is 'SSDoingRecovery' (which is -- equivalent to “we're doing recovery”). -recoveryInProgress :: MonadRecoveryInfo ctx m => m Bool -recoveryInProgress = - getSyncStatus 0 {- 0 doesn't matter -} <&> \case +recoveryInProgress :: MonadRecoveryInfo ctx 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 ctx m - => 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 ctx m, WithLogger m) - => Text -> m () -> m () -recoveryCommGuard actionName action = - getSyncStatusK >>= \case + :: (MonadRecoveryInfo ctx 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/src/Pos/Infra/Slotting/Impl/Simple.hs b/infra/src/Pos/Infra/Slotting/Impl/Simple.hs index 99b101c24f9..b8b54117892 100644 --- a/infra/src/Pos/Infra/Slotting/Impl/Simple.hs +++ b/infra/src/Pos/Infra/Slotting/Impl/Simple.hs @@ -20,10 +20,9 @@ module Pos.Infra.Slotting.Impl.Simple import Universum import Pos.Core.Conc (currentTime) -import Pos.Core.Configuration (HasProtocolConstants) -import Pos.Core.Slotting (MonadSlotsData, SlotId (..), Timestamp (..), - getCurrentNextEpochIndexM, unflattenSlotId, - waitCurrentEpochEqualsM) +import Pos.Core.Slotting (MonadSlotsData, SlotCount, SlotId (..), + Timestamp (..), getCurrentNextEpochIndexM, + unflattenSlotId, waitCurrentEpochEqualsM) import Pos.Infra.Slotting.Impl.Util (approxSlotUsingOutdated, slotFromTimestamp) import Pos.Util (HasLens (..)) @@ -53,64 +52,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 <$> readTVarIO 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/src/Pos/Infra/Slotting/Impl/Util.hs b/infra/src/Pos/Infra/Slotting/Impl/Util.hs index e13d5b18b23..8807b45a5e8 100644 --- a/infra/src/Pos/Infra/Slotting/Impl/Util.hs +++ b/infra/src/Pos/Infra/Slotting/Impl/Util.hs @@ -13,22 +13,22 @@ import Universum import Data.Time.Units (convertUnit) -import Pos.Core.Configuration (HasProtocolConstants) import Pos.Core.Slotting (EpochIndex, EpochSlottingData (..), - MonadSlotsData, SlotId (..), SlottingData, Timestamp (..), - addTimeDiffToTimestamp, flattenEpochIndex, - getSystemStartM, slotFromTimestamp, unflattenSlotId, - withSlottingVarAtomM) + MonadSlotsData, SlotCount, SlotId (..), SlottingData, + Timestamp (..), addTimeDiffToTimestamp, flattenEpochIndex, + getSystemStartM, localSlotIndexMinBound, + slotFromTimestamp, unflattenSlotId, withSlottingVarAtomM) import Pos.Infra.Slotting.Types (getCurrentEpochIndex, getNextEpochSlottingData) -- | 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 @@ -38,15 +38,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. diff --git a/infra/src/Pos/Infra/Slotting/Util.hs b/infra/src/Pos/Infra/Slotting/Util.hs index cc2e77db5b9..64270c44d05 100644 --- a/infra/src/Pos/Infra/Slotting/Util.hs +++ b/infra/src/Pos/Infra/Slotting/Util.hs @@ -34,7 +34,8 @@ import Data.Time.Units (Millisecond, fromMicroseconds) import Formatting (int, sformat, shown, stext, (%)) import UnliftIO (MonadUnliftIO) -import Pos.Core (LocalSlotIndex, SlotId (..), Timestamp (..), slotIdF) +import Pos.Core (LocalSlotIndex, SlotCount, SlotId (..), + Timestamp (..), slotIdF, slotIdSucc) import Pos.Core.Conc (delay, timeout) import Pos.Core.Slotting (ActionTerminationPolicy (..), EpochSlottingData (..), MonadSlotsData, @@ -115,22 +116,23 @@ type MonadOnNewSlot ctx m = -- it. onNewSlot :: MonadOnNewSlot ctx m - => OnNewSlotParams -> (SlotId -> m ()) -> m () -onNewSlot = onNewSlotImpl False + => SlotCount -> OnNewSlotParams -> (SlotId -> m ()) -> m () +onNewSlot epochSlots = onNewSlotImpl epochSlots False onNewSlotWithLogging :: MonadOnNewSlot ctx m - => OnNewSlotParams -> (SlotId -> m ()) -> m () -onNewSlotWithLogging = onNewSlotImpl True + => 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 - => 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 () @@ -141,15 +143,15 @@ 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 - => Bool -> Maybe SlotId -> OnNewSlotParams -> (SlotId -> m ()) -> m () -onNewSlotDo withLogging expectedSlotId onsp action = do + => 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 @@ -168,7 +170,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 @@ -176,8 +178,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. @@ -190,9 +192,9 @@ onNewSlotDo withLogging expectedSlotId onsp action = do logTTW timeToWait = modifyLoggerName (<> "slotting") $ logDebug $ sformat ("Waiting for "%shown%" before new slot") timeToWait -logNewSlotWorker :: MonadOnNewSlot ctx m => 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/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs b/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs index d8012ae9bf3..2a52324cff5 100644 --- a/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs +++ b/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs @@ -279,7 +279,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 $ Block.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 301864401ba..10806e9467f 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 @@ -12,9 +9,9 @@ import Universum import Pos.Chain.Block (genesisBlock0, headerHash) import Pos.Chain.Lrc (genesisLeaders) -import Pos.Core (GenesisHash (..), SlotCount, genesisHash) +import Pos.Core as Core (Config (..), GenesisHash (..), + configEpochSlots, genesisHash) import Pos.Core.Update (BlockVersionData) -import Pos.Crypto (ProtocolMagic) import Pos.DB.Block (prepareBlockDB) import Pos.DB.Class (MonadDB, MonadDBRead (..)) import Pos.DB.Lrc (prepareLrcDB) @@ -23,18 +20,20 @@ import Pos.GState.GState (prepareGStateDB) -- | 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) + => Core.Config + -> m () +initNodeDBs coreConfig = do let initialTip = headerHash gb prepareBlockDB gb - prepareGStateDB initialTip + prepareGStateDB (configProtocolConstants coreConfig) initialTip prepareLrcDB epochSlots where - gb = genesisBlock0 pm (GenesisHash genesisHash) (genesisLeaders epochSlots) + epochSlots = configEpochSlots coreConfig + gb = genesisBlock0 (configProtocolMagic coreConfig) + (GenesisHash genesisHash) + (genesisLeaders epochSlots) ---------------------------------------------------------------------------- -- MonadGState instance diff --git a/lib/src/Pos/GState/GState.hs b/lib/src/Pos/GState/GState.hs index 18f26a1704a..e522ce37048 100644 --- a/lib/src/Pos/GState/GState.hs +++ b/lib/src/Pos/GState/GState.hs @@ -8,7 +8,7 @@ import Universum import Pos.Chain.Block (HeaderHash) import Pos.Chain.Txp (genesisUtxo) -import Pos.Core (genesisData) +import Pos.Core (ProtocolConstants, genesisData) import Pos.Core.Genesis (gdHeavyDelegation) import Pos.DB.Block (initGStateBlockExtra) import Pos.DB.Class (MonadDB) @@ -25,14 +25,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/Launcher.hs b/lib/src/Pos/Launcher/Launcher.hs index 10ae306f439..f8969bc1584 100644 --- a/lib/src/Pos/Launcher/Launcher.hs +++ b/lib/src/Pos/Launcher/Launcher.hs @@ -12,8 +12,7 @@ import Universum import Pos.Chain.Ssc (SscParams) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Core.Configuration (epochSlots) -import Pos.Crypto (ProtocolMagic) +import Pos.Core as Core (Config (..), configBlkSecurityParam) import Pos.DB.DB (initNodeDBs) import Pos.DB.Txp (txpGlobalSettings) import Pos.Infra.Diffusion.Types (Diffusion) @@ -32,17 +31,26 @@ import Pos.WorkMode (EmptyMempoolExt, RealMode) -- | Run full node in real mode. runNodeReal - :: ( HasConfigurations - , HasCompileInfo - ) - => ProtocolMagic + :: (HasConfigurations, HasCompileInfo) + => Core.Config -> TxpConfiguration -> NodeParams -> SscParams - -> [Diffusion (RealMode EmptyMempoolExt) -> RealMode EmptyMempoolExt ()] + -> [ Diffusion (RealMode EmptyMempoolExt) + -> RealMode EmptyMempoolExt () + ] -> IO () -runNodeReal pm txpConfig np sscnp plugins = - bracketNodeResources np sscnp (txpGlobalSettings pm txpConfig) (initNodeDBs pm epochSlots) action +runNodeReal coreConfig txpConfig np sscnp plugins = bracketNodeResources + (configBlkSecurityParam coreConfig) + np + sscnp + (txpGlobalSettings (configProtocolMagic coreConfig) txpConfig) + (initNodeDBs coreConfig) + action where action :: NodeResources EmptyMempoolExt -> IO () - action nr@NodeResources {..} = runRealMode pm txpConfig nr (runNode pm txpConfig nr plugins) + action nr@NodeResources {..} = runRealMode + coreConfig + txpConfig + nr + (runNode coreConfig txpConfig nr plugins) diff --git a/lib/src/Pos/Launcher/Mode.hs b/lib/src/Pos/Launcher/Mode.hs index b2f9fa5f35c..16e1c42b0e6 100644 --- a/lib/src/Pos/Launcher/Mode.hs +++ b/lib/src/Pos/Launcher/Mode.hs @@ -88,9 +88,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 0ab11ce5812..0ad342ac095 100644 --- a/lib/src/Pos/Launcher/Resource.hs +++ b/lib/src/Pos/Launcher/Resource.hs @@ -41,7 +41,8 @@ import Pos.Client.CLI.Util (readLoggerConfig) import Pos.Configuration import Pos.Context (ConnectedPeers (..), NodeContext (..), StartTime (..)) -import Pos.Core (HasConfiguration, Timestamp, genesisData) +import Pos.Core (BlockCount, HasConfiguration, Timestamp, genesisData, + kEpochSlots) import Pos.Core.Genesis (gdStartTime) import Pos.Core.Reporting (initializeMisbehaviorMetrics) import Pos.DB (MonadDBRead, NodeDBs) @@ -103,12 +104,13 @@ allocateNodeResources , HasDlgConfiguration , HasBlockConfiguration ) - => NodeParams + => BlockCount + -> NodeParams -> SscParams -> TxpGlobalSettings -> InitMode () -> IO (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 +149,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 @@ -200,16 +202,17 @@ bracketNodeResources :: forall ext a. , HasDlgConfiguration , HasBlockConfiguration ) - => NodeParams + => BlockCount + -> NodeParams -> SscParams -> TxpGlobalSettings -> InitMode () -> (HasConfiguration => NodeResources ext -> IO a) -> IO 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. @@ -258,11 +261,13 @@ data AllocateNodeContextData ext = AllocateNodeContextData allocateNodeContext :: forall ext . (HasConfiguration, HasNodeConfiguration, HasBlockConfiguration) - => AllocateNodeContextData ext + => 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" @@ -296,11 +301,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 4eb50ca88e7..41865a0e304 100644 --- a/lib/src/Pos/Launcher/Runner.hs +++ b/lib/src/Pos/Launcher/Runner.hs @@ -32,9 +32,7 @@ import Pos.Chain.Update (HasUpdateConfiguration, import Pos.Configuration (HasNodeConfiguration, networkConnectionTimeout) import Pos.Context.Context (NodeContext (..)) -import Pos.Core (StakeholderId, addressHash) -import Pos.Core.Configuration (HasProtocolConstants, - protocolConstants) +import Pos.Core as Core (Config (..), StakeholderId, addressHash) import Pos.Core.JsonLog (jsonLog) import Pos.Crypto (ProtocolMagic, toPublic) import Pos.DB.Txp (MonadTxpLocal) @@ -77,13 +75,13 @@ runRealMode -- explorer and wallet use RealMode, -- though they should use only @RealModeContext@ ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> NodeResources ext -> (Diffusion (RealMode ext) -> RealMode ext a) -> IO a -runRealMode pm txpConfig nr@NodeResources {..} act = runServer - pm +runRealMode coreConfig txpConfig nr@NodeResources {..} act = runServer + coreConfig ncNodeParams (EkgNodeMetrics nrEkgStore) ncShutdownContext @@ -91,12 +89,13 @@ runRealMode pm txpConfig 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 txpConfig ourStakeholderId securityParams jsonLog + logic = logicFull coreConfig txpConfig ourStakeholderId securityParams jsonLog + pm = configProtocolMagic coreConfig makeLogicIO :: Diffusion IO -> Logic IO makeLogicIO diffusion = hoistLogic (elimRealMode pm nr diffusion) logic act' :: Diffusion IO -> IO a @@ -146,20 +145,16 @@ elimRealMode pm NodeResources {..} diffusion action = do -- network connection timeout (nt-tcp), and, and the 'recoveryHeadersMessage' -- number. runServer - :: forall t . - ( HasProtocolConstants - , HasBlockConfiguration - , HasNodeConfiguration - , HasUpdateConfiguration - ) - => ProtocolMagic + :: forall t + . (HasBlockConfiguration, HasNodeConfiguration, HasUpdateConfiguration) + => Core.Config -> NodeParams -> EkgNodeMetrics -> ShutdownContext -> (Diffusion IO -> Logic IO) -> (Diffusion IO -> IO t) -> IO t -runServer pm NodeParams {..} ekgNodeMetrics shdnContext mkLogic act = exitOnShutdown $ +runServer coreConfig NodeParams {..} ekgNodeMetrics shdnContext mkLogic act = exitOnShutdown $ diffusionLayerFull fdconf npNetworkConfig (Just ekgNodeMetrics) @@ -175,8 +170,8 @@ runServer pm NodeParams {..} ekgNodeMetrics shdnContext mkLogic act = exitOnShut where fdconf = FullDiffusionConfiguration - { fdcProtocolMagic = pm - , fdcProtocolConstants = protocolConstants + { fdcProtocolMagic = configProtocolMagic coreConfig + , fdcProtocolConstants = configProtocolConstants coreConfig , fdcRecoveryHeadersMessage = recoveryHeadersMessage , fdcLastKnownBlockVersion = lastKnownBlockVersion , fdcConvEstablishTimeout = networkConnectionTimeout diff --git a/lib/src/Pos/Launcher/Scenario.hs b/lib/src/Pos/Launcher/Scenario.hs index 2b7b3e5b6b1..2886c979f38 100644 --- a/lib/src/Pos/Launcher/Scenario.hs +++ b/lib/src/Pos/Launcher/Scenario.hs @@ -20,11 +20,11 @@ import Pos.Chain.Txp (TxpConfiguration, bootDustThreshold) import Pos.Chain.Update (HasUpdateConfiguration, curSoftwareVersion, lastKnownBlockVersion, ourSystemTag) import Pos.Context (getOurPublicKey) -import Pos.Core (addressHash, genesisData) +import Pos.Core as Core (Config, addressHash, genesisData) import Pos.Core.Conc (mapConcurrently) import Pos.Core.Genesis (GenesisData (..), GenesisDelegation (..), GenesisWStakeholders (..), gdFtsSeed) -import Pos.Crypto (ProtocolMagic, pskDelegatePk) +import Pos.Crypto (pskDelegatePk) import qualified Pos.DB.BlockIndex as DB import qualified Pos.GState as GS import Pos.Infra.Diffusion.Types (Diffusion) @@ -107,14 +107,14 @@ runNode :: ( HasCompileInfo , WorkMode ctx m ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> NodeResources ext -> [Diffusion m -> m ()] -> Diffusion m -> m () -runNode pm txpConfig nr plugins = runNode' nr workers' plugins +runNode coreConfig txpConfig nr plugins = runNode' nr workers' plugins where - workers' = allWorkers pm txpConfig nr + workers' = allWorkers coreConfig txpConfig nr -- | This function prints a very useful message when node is started. nodeStartMsg :: (HasUpdateConfiguration, WithLogger m) => m () diff --git a/lib/src/Pos/Listener/Txp.hs b/lib/src/Pos/Listener/Txp.hs index 35cb7d2818f..1847081880a 100644 --- a/lib/src/Pos/Listener/Txp.hs +++ b/lib/src/Pos/Listener/Txp.hs @@ -18,8 +18,9 @@ import Node.Message.Class (Message) import Universum import Pos.Chain.Txp (TxpConfiguration) +import Pos.Core as Core (Config) import Pos.Core.Txp (TxAux (..), TxId, TxMsgContents (..)) -import Pos.Crypto (ProtocolMagic, hash) +import Pos.Crypto (hash) import Pos.DB.Txp.MemState (MempoolExt, MonadTxpLocal, MonadTxpMem, txpProcessTx) import qualified Pos.Infra.Communication.Relay as Relay @@ -31,27 +32,34 @@ import Pos.Util.Wlog (WithLogger, logInfo) -- #txProcessTransaction handleTxDo :: TxpMode ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (JLEvent -> m ()) -- ^ How to log transactions -> TxAux -- ^ Incoming transaction to be processed -> m Bool -handleTxDo pm txpConfig logTx txAux = do +handleTxDo coreConfig txpConfig logTx txAux = do let txId = hash (taTx txAux) - res <- txpProcessTx pm txpConfig (txId, txAux) + res <- txpProcessTx coreConfig txpConfig (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/lib/src/Pos/Listener/Update.hs b/lib/src/Pos/Listener/Update.hs index 7744a386eea..e8d3659e847 100644 --- a/lib/src/Pos/Listener/Update.hs +++ b/lib/src/Pos/Listener/Update.hs @@ -16,7 +16,7 @@ import Formatting (build, sformat, (%)) import UnliftIO (MonadUnliftIO) import Pos.Chain.Update (HasUpdateConfiguration, UpdateParams) -import Pos.Core (ProtocolMagic) +import Pos.Core as Core (Config) import Pos.Core.Update (UpdateProposal (..), UpdateVote (..)) import Pos.DB.Class (MonadDB, MonadGState) import Pos.DB.Lrc (HasLrcContext) @@ -53,17 +53,17 @@ type UpdateMode ctx m handleProposal :: forall ctx m . UpdateMode ctx m - => ProtocolMagic + => Core.Config -> (UpdateProposal, [UpdateVote]) -> m Bool -handleProposal pm (proposal, votes) = do - res <- processProposal pm proposal +handleProposal coreConfig (proposal, votes) = do + res <- processProposal coreConfig 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 coreConfig vote >>= logVote vote logVote vote (Left cause) = logWarning $ sformat ("Proposal is accepted but vote "%build% " is rejected, the reason is: "%build) @@ -86,11 +86,11 @@ handleProposal pm (proposal, votes) = do handleVote :: UpdateMode ctx m - => ProtocolMagic + => Core.Config -> UpdateVote -> m Bool -handleVote pm uv = do - res <- processVote pm uv +handleVote coreConfig uv = do + res <- processVote coreConfig uv logProcess uv res pure $ isRight res where diff --git a/lib/src/Pos/Logic/Full.hs b/lib/src/Pos/Logic/Full.hs index fa88320241b..3ba5c95b38f 100644 --- a/lib/src/Pos/Logic/Full.hs +++ b/lib/src/Pos/Logic/Full.hs @@ -23,14 +23,15 @@ import Pos.Chain.Ssc (MCCommitment (..), MCOpening (..), tmCertificates, tmCommitments, tmOpenings, tmShares) import Pos.Chain.Txp (MemPool (..), TxpConfiguration) import Pos.Communication (NodeId) -import Pos.Core (HasConfiguration, StakeholderId, addressHash) +import Pos.Core as Core (Config (..), HasConfiguration, StakeholderId, + addressHash, configBlkSecurityParam, configEpochSlots) import Pos.Core.Chrono (NE, NewestFirst, OldestFirst) import Pos.Core.Delegation (ProxySKHeavy) import Pos.Core.Ssc (getCertId, getCommitmentsMap, lookupVss) import Pos.Core.Txp (TxAux (..), TxMsgContents (..)) import Pos.Core.Update (BlockVersionData, UpdateProposal (..), UpdateVote (..)) -import Pos.Crypto (ProtocolMagic, hash) +import Pos.Crypto (hash) import qualified Pos.DB.Block as Block import qualified Pos.DB.Block as DB (getTipBlock) import qualified Pos.DB.BlockIndex as DB (getHeader, getTipHeader) @@ -94,14 +95,14 @@ type LogicWorkMode ctx m = -- monadX constraints to do most of its work. logicFull :: forall ctx m . - ( LogicWorkMode ctx m ) - => ProtocolMagic + LogicWorkMode ctx m + => Core.Config -> TxpConfiguration -> StakeholderId -> SecurityParams -> (JLEvent -> m ()) -- ^ JSON log callback. FIXME replace by structured logging solution -> Logic m -logicFull pm txpConfig ourStakeholderId securityParams jsonLogTx = +logicFull coreConfig txpConfig ourStakeholderId securityParams jsonLogTx = let getSerializedBlock :: HeaderHash -> m (Maybe SerializedBlock) getSerializedBlock = DB.dbGetSerBlock @@ -119,7 +120,8 @@ logicFull pm txpConfig ourStakeholderId securityParams jsonLogTx = getAdoptedBVData = gsAdoptedBVData recoveryInProgress :: m Bool - recoveryInProgress = Recovery.recoveryInProgress + recoveryInProgress = + Recovery.recoveryInProgress $ configEpochSlots coreConfig getBlockHeader :: HeaderHash -> m (Maybe BlockHeader) getBlockHeader = DB.getHeader @@ -135,7 +137,11 @@ logicFull pm txpConfig ourStakeholderId securityParams jsonLogTx = :: 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 @@ -144,23 +150,23 @@ logicFull pm txpConfig ourStakeholderId securityParams jsonLogTx = getLcaMainChain = Block.lcaWithMainChainSuffix postBlockHeader :: BlockHeader -> NodeId -> m () - postBlockHeader = Block.handleUnsolicitedHeader pm + postBlockHeader = Block.handleUnsolicitedHeader coreConfig postPskHeavy :: ProxySKHeavy -> m Bool - postPskHeavy = Delegation.handlePsk pm + postPskHeavy = Delegation.handlePsk $ configProtocolMagic coreConfig 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 txpConfig jsonLogTx txAux + , handleData = \(TxMsgContents txAux) -> Txp.handleTxDo coreConfig txpConfig jsonLogTx txAux } postUpdate = KeyVal { toKey = \(up, _) -> pure . tag $ hash up , handleInv = isProposalNeeded . unTagged , handleReq = getLocalProposalNVotes . unTagged - , handleData = handleProposal pm + , handleData = handleProposal coreConfig } where tag = tagWith (Proxy :: Proxy (UpdateProposal, [UpdateVote])) @@ -169,7 +175,7 @@ logicFull pm txpConfig ourStakeholderId securityParams jsonLogTx = { toKey = \UnsafeUpdateVote{..} -> pure $ tag (uvProposalId, uvKey, uvDecision) , handleInv = \(Tagged (id, pk, dec)) -> isVoteNeeded id pk dec , handleReq = \(Tagged (id, pk, dec)) -> getLocalVote id pk dec - , handleData = handleVote pm + , handleData = handleVote coreConfig } where tag = tagWith (Proxy :: Proxy UpdateVote) @@ -178,28 +184,28 @@ logicFull pm txpConfig ourStakeholderId securityParams jsonLogTx = CommitmentMsg (\(MCCommitment (pk, _, _)) -> addressHash pk) (\id tm -> MCCommitment <$> tm ^. tmCommitments . to getCommitmentsMap . at id) - (\(MCCommitment comm) -> sscProcessCommitment pm comm) + (\(MCCommitment comm) -> sscProcessCommitment coreConfig 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 coreConfig 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 coreConfig key shares) postSscVssCert = postSscCommon VssCertificateMsg (\(MCVssCertificate vc) -> getCertId vc) (\id tm -> MCVssCertificate <$> lookupVss id (tm ^. tmCertificates)) - (\(MCVssCertificate cert) -> sscProcessCertificate pm cert) + (\(MCVssCertificate cert) -> sscProcessCertificate coreConfig cert) postSscCommon - :: ( Buildable err, Buildable contents ) + :: (Buildable err, Buildable contents) => SscTag -> (contents -> StakeholderId) -> (StakeholderId -> TossModifier -> Maybe contents) @@ -207,7 +213,9 @@ logicFull pm txpConfig ourStakeholderId securityParams jsonLogTx = -> KeyVal (Tagged contents StakeholderId) contents m postSscCommon sscTag contentsToKey toContents processData = KeyVal { toKey = pure . tagWith contentsProxy . contentsToKey - , handleInv = sscIsDataUseful sscTag . unTagged + , handleInv = + sscIsDataUseful (configBlkSecurityParam coreConfig) sscTag + . unTagged , handleReq = \(Tagged addr) -> toContents addr . view ldModifier <$> sscRunLocalQuery ask , handleData = \dat -> do let addr = contentsToKey dat @@ -228,5 +236,4 @@ logicFull pm txpConfig ourStakeholderId securityParams jsonLogTx = sscProcessMessageDo dat >>= \case Left err -> False <$ logDebug (sformat ("Data is rejected, reason: "%build) err) Right () -> return True - in Logic {..} diff --git a/lib/src/Pos/Network/Block/Logic.hs b/lib/src/Pos/Network/Block/Logic.hs index a331ca9a38a..96e7efb0c7a 100644 --- a/lib/src/Pos/Network/Block/Logic.hs +++ b/lib/src/Pos/Network/Block/Logic.hs @@ -30,7 +30,8 @@ import Pos.Chain.Block (ApplyBlocksException, Block, BlockHeader, Blund, HasHeaderHash (..), HeaderHash, LastKnownHeaderTag, blockHeader, gbHeader, headerHashG, prevBlockL) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Core (isMoreDifficult) +import Pos.Core as Core (Config, SlotCount, configEpochSlots, + isMoreDifficult) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), _NewestFirst, _OldestFirst) import Pos.Core.Conc (forConcurrently) @@ -40,7 +41,7 @@ import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), MisbehaviorMetrics (..)) import Pos.Core.Slotting (MonadSlots (getCurrentSlot)) -import Pos.Crypto (ProtocolMagic, shortHashF) +import Pos.Crypto (shortHashF) import Pos.DB.Block (ClassifyHeaderRes (..), classifyNewHeader, lcaWithMainChain, verifyAndApplyBlocks) import qualified Pos.DB.Block as L @@ -100,8 +101,8 @@ instance Exception BlockNetLogicException where triggerRecovery :: ( BlockWorkMode ctx m ) - => ProtocolMagic -> Diffusion m -> m () -triggerRecovery pm diffusion = unlessM recoveryInProgress $ do + => Core.Config -> Diffusion m -> m () +triggerRecovery coreConfig diffusion = unlessM (recoveryInProgress $ configEpochSlots coreConfig) $ 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 @@ -124,24 +125,23 @@ triggerRecovery pm diffusion = unlessM recoveryInProgress $ do -- downloaded. bh <- mbh -- I know, it's not unsolicited. TODO rename. - handleUnsolicitedHeader pm bh nodeId + handleUnsolicitedHeader coreConfig bh nodeId ---------------------------------------------------------------------------- -- Headers processing ---------------------------------------------------------------------------- handleUnsolicitedHeader - :: ( BlockWorkMode ctx m - ) - => ProtocolMagic + :: BlockWorkMode ctx m + => Core.Config -> BlockHeader -> NodeId -> m () -handleUnsolicitedHeader pm header nodeId = do +handleUnsolicitedHeader coreConfig header nodeId = do logDebug $ sformat ("handleUnsolicitedHeader: single header was propagated, processing:\n" %build) header - classificationRes <- classifyNewHeader pm header + classificationRes <- classifyNewHeader coreConfig header -- TODO: should we set 'To' hash to hash of header or leave it unlimited? case classificationRes of CHContinues -> do @@ -164,7 +164,7 @@ handleUnsolicitedHeader pm header nodeId = do "Header " %shortHashF % " potentially represents good alternative chain, will process" uselessFormat = - "Header " %shortHashF % " is useless for the following reason: " %stext + "Header " %shortHashF%" is useless for the following reason: " %stext ---------------------------------------------------------------------------- -- Putting things into request queue @@ -225,12 +225,12 @@ handleBlocks ( BlockWorkMode ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> OldestFirst NE Block -> Diffusion m -> m () -handleBlocks pm txpConfig blocks diffusion = do +handleBlocks coreConfig txpConfig blocks diffusion = do logDebug "handleBlocks: processing" inAssertMode $ logInfo $ sformat ("Processing sequence of blocks: " % buildListBounds % "...") $ @@ -248,8 +248,8 @@ handleBlocks pm txpConfig 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 txpConfig diffusion blocks) - (applyWithRollback pm txpConfig diffusion blocks lcaHash) + maybe (applyWithoutRollback coreConfig txpConfig diffusion blocks) + (applyWithRollback coreConfig txpConfig diffusion blocks lcaHash) (_NewestFirst nonEmpty toRollback) applyWithoutRollback @@ -257,12 +257,12 @@ applyWithoutRollback ( BlockWorkMode ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> Diffusion m -> OldestFirst NE Block -> m () -applyWithoutRollback pm txpConfig diffusion blocks = do +applyWithoutRollback coreConfig txpConfig diffusion blocks = do logInfo . sformat ("Trying to apply blocks w/o rollback. " % multilineBounds 6) . getOldestFirst . map (view blockHeader) $ blocks modifyStateLock HighPriority ApplyBlock applyWithoutRollbackDo >>= \case @@ -282,17 +282,18 @@ applyWithoutRollback pm txpConfig diffusion blocks = do & map (view blockHeader) applied = NE.fromList $ getOldestFirst prefix <> one (toRelay ^. blockHeader) - relayBlock diffusion toRelay + relayBlock epochSlots diffusion toRelay logInfo $ blocksAppliedMsg applied for_ blocks $ jsonLog . jlAdoptedBlock where + epochSlots = configEpochSlots coreConfig newestTip = blocks ^. _OldestFirst . _neLast . headerHashG applyWithoutRollbackDo :: HeaderHash -> m (HeaderHash, Either ApplyBlocksException HeaderHash) applyWithoutRollbackDo curTip = do logInfo "Verifying and applying blocks..." - curSlot <- getCurrentSlot - res <- fmap fst <$> verifyAndApplyBlocks pm txpConfig curSlot False blocks + curSlot <- getCurrentSlot epochSlots + res <- fmap fst <$> verifyAndApplyBlocks coreConfig txpConfig curSlot False blocks logInfo "Verifying and applying blocks done" let newTip = either (const curTip) identity res pure (newTip, res) @@ -301,19 +302,19 @@ applyWithRollback :: ( BlockWorkMode ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> Diffusion m -> OldestFirst NE Block -> HeaderHash -> NewestFirst NE Blund -> m () -applyWithRollback pm txpConfig diffusion toApply lca toRollback = do +applyWithRollback coreConfig txpConfig 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 txpConfig toRollback toApplyAfterLca + res <- L.applyWithRollback coreConfig txpConfig toRollback toApplyAfterLca pure (either (const curTip) identity res, res) case res of Left (pretty -> err) -> @@ -326,7 +327,8 @@ applyWithRollback pm txpConfig diffusion toApply lca toRollback = do logInfo $ blocksRolledBackMsg (getNewestFirst toRollback) logInfo $ blocksAppliedMsg (getOldestFirst toApply) for_ (getOldestFirst toApply) $ jsonLog . jlAdoptedBlock - relayBlock diffusion $ toApply ^. _OldestFirst . _neLast + relayBlock (configEpochSlots coreConfig) diffusion + $ toApply ^. _OldestFirst . _neLast where toRollbackHashes = fmap headerHash toRollback reportRollback = do @@ -346,11 +348,11 @@ applyWithRollback pm txpConfig diffusion toApply lca toRollback = do 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" + => 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) @@ -362,8 +364,8 @@ relayBlock diffusion (Right mainBlk) = do -- TODO: ban node for it! onFailedVerifyBlocks - :: forall ctx m. - (BlockWorkMode ctx 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) diff --git a/lib/src/Pos/Network/Block/Retrieval.hs b/lib/src/Pos/Network/Block/Retrieval.hs index efbd6bb8406..1831f03f2f5 100644 --- a/lib/src/Pos/Network/Block/Retrieval.hs +++ b/lib/src/Pos/Network/Block/Retrieval.hs @@ -21,11 +21,12 @@ import Formatting (build, int, sformat, (%)) import Pos.Chain.Block (Block, BlockHeader, HasHeaderHash (..), HeaderHash) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Core (difficultyL, isMoreDifficult) +import Pos.Core as Core (Config, configBlkSecurityParam, difficultyL, + isMoreDifficult) import Pos.Core.Chrono (NE, OldestFirst (..), _OldestFirst) import Pos.Core.Conc (delay) import Pos.Core.Reporting (HasMisbehaviorMetrics) -import Pos.Crypto (ProtocolMagic, shortHashF) +import Pos.Crypto (shortHashF) import Pos.DB.Block (ClassifyHeaderRes (..), classifyNewHeader, getHeadersOlderExp) import qualified Pos.DB.BlockIndex as DB @@ -60,10 +61,10 @@ retrievalWorker ( BlockWorkMode ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> Diffusion m -> m () -retrievalWorker pm txpConfig diffusion = do +retrievalWorker coreConfig txpConfig diffusion = do logInfo "Starting retrievalWorker loop" mainLoop where @@ -113,9 +114,9 @@ retrievalWorker pm txpConfig diffusion = do handleContinues nodeId header = do let hHash = headerHash header logDebug $ "handleContinues: " <> pretty hHash - classifyNewHeader pm header >>= \case + classifyNewHeader coreConfig header >>= \case CHContinues -> - void $ getProcessBlocks pm txpConfig diffusion nodeId (headerHash header) [hHash] + void $ getProcessBlocks coreConfig txpConfig diffusion nodeId (headerHash header) [hHash] res -> logDebug $ "processContHeader: expected header to " <> "be continuation, but it's " <> show res @@ -125,7 +126,7 @@ retrievalWorker pm txpConfig diffusion = do -- enter recovery mode. handleAlternative nodeId header = do logDebug $ "handleAlternative: " <> pretty (headerHash header) - classifyNewHeader pm header >>= \case + classifyNewHeader coreConfig header >>= \case CHInvalid _ -> logError "handleAlternative: invalid header got into retrievalWorker queue" CHUseless _ -> @@ -157,7 +158,7 @@ retrievalWorker pm txpConfig diffusion = do reportOrLogW (sformat ("handleRecoveryE: error handling nodeId="%build%", header="%build%": ") nodeId (headerHash rHeader)) e - dropRecoveryHeaderAndRepeat pm diffusion nodeId + dropRecoveryHeaderAndRepeat coreConfig diffusion nodeId -- Recovery handling. We assume that header in the recovery variable is -- appropriate and just query headers/blocks. @@ -170,8 +171,15 @@ retrievalWorker pm txpConfig diffusion = do throwM $ DialogUnexpected $ "handleRecovery: recovery header is " <> "already present in db" logDebug "handleRecovery: fetching blocks" - checkpoints <- toList <$> getHeadersOlderExp Nothing - void $ streamProcessBlocks pm txpConfig diffusion nodeId (headerHash rHeader) checkpoints + checkpoints <- toList <$> getHeadersOlderExp + (configBlkSecurityParam coreConfig) + Nothing + void $ streamProcessBlocks coreConfig + txpConfig + diffusion + nodeId + (headerHash rHeader) + checkpoints ---------------------------------------------------------------------------- -- Entering and exiting recovery mode @@ -257,8 +265,12 @@ 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 + => Core.Config + -> Diffusion m + -> NodeId + -> m () +dropRecoveryHeaderAndRepeat coreConfig diffusion nodeId = do kicked <- dropRecoveryHeader nodeId when kicked $ attemptRestartRecovery where @@ -266,7 +278,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 coreConfig diffusion logDebug "Attempting to restart recovery over" handleRecoveryTriggerE = -- REPORT:ERROR 'reportOrLogE' somewhere in block retrieval. @@ -276,18 +288,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 - ) - => ProtocolMagic + :: forall ctx m + . (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) + => Core.Config -> TxpConfiguration -> Diffusion m -> NodeId -> HeaderHash -> [HeaderHash] -> m () -getProcessBlocks pm txpConfig diffusion nodeId desired checkpoints = do +getProcessBlocks coreConfig txpConfig diffusion nodeId desired checkpoints = do result <- Diffusion.getBlocks diffusion nodeId desired checkpoints case OldestFirst <$> nonEmpty (getOldestFirst result) of Nothing -> do @@ -300,7 +310,7 @@ getProcessBlocks pm txpConfig diffusion nodeId desired checkpoints = do logDebug $ sformat ("Retrieved "%int%" blocks") (blocks ^. _OldestFirst . to NE.length) - handleBlocks pm txpConfig blocks diffusion + handleBlocks coreConfig txpConfig blocks diffusion -- If we've downloaded any block with bigger -- difficulty than ncRecoveryHeader, we're -- gracefully exiting recovery mode. @@ -322,24 +332,22 @@ getProcessBlocks pm txpConfig 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 - ) - => ProtocolMagic + :: forall ctx m + . (BlockWorkMode ctx m, HasMisbehaviorMetrics ctx) + => Core.Config -> TxpConfiguration -> Diffusion m -> NodeId -> HeaderHash -> [HeaderHash] -> m () -streamProcessBlocks pm txpConfig diffusion nodeId desired checkpoints = do +streamProcessBlocks coreConfig txpConfig diffusion nodeId desired checkpoints = do logInfo "streaming start" r <- Diffusion.streamBlocks diffusion nodeId desired checkpoints writeCallback case r of Nothing -> do logInfo "streaming not supported, reverting to batch mode" - getProcessBlocks pm txpConfig diffusion nodeId desired checkpoints + getProcessBlocks coreConfig txpConfig diffusion nodeId desired checkpoints Just _ -> do logInfo "streaming done" return () @@ -347,4 +355,4 @@ streamProcessBlocks pm txpConfig diffusion nodeId desired checkpoints = do writeCallback :: [Block] -> m () writeCallback [] = return () writeCallback (block:blocks) = - handleBlocks pm txpConfig (OldestFirst (NE.reverse $ block :| blocks)) diffusion + handleBlocks coreConfig txpConfig (OldestFirst (NE.reverse $ block :| blocks)) diffusion diff --git a/lib/src/Pos/Recovery/Instance.hs b/lib/src/Pos/Recovery/Instance.hs new file mode 100644 index 00000000000..e59269b2b06 --- /dev/null +++ b/lib/src/Pos/Recovery/Instance.hs @@ -0,0 +1,56 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | An instance of 'MonadRecoveryInfo'. + +module Pos.Recovery.Instance + ( + ) where + +import Universum + +import qualified Control.Concurrent.STM as STM +import Control.Monad.Except (runExceptT, throwError) + +import Pos.Block.BHelpers () +import Pos.Block.Types (RecoveryHeader, RecoveryHeaderTag) +import Pos.Core (epochOrSlotG, epochOrSlotToSlot, flattenSlotId) +import qualified Pos.DB.BlockIndex as DB +import Pos.DB.Class (MonadDBRead) +import Pos.Infra.Recovery.Info (MonadRecoveryInfo (..), + SyncStatus (..)) +import Pos.Infra.Slotting (MonadSlots (getCurrentSlot)) +import Pos.Util.Util (HasLens (..)) + +instance ( Monad m + , MonadIO m + , MonadDBRead m + , MonadSlots ctx m + , MonadReader ctx m + , HasLens RecoveryHeaderTag ctx RecoveryHeader + ) => + MonadRecoveryInfo m where + getSyncStatus epochSlots lagBehindParam = + fmap convertRes . runExceptT $ do + recoveryIsInProgress >>= \case + False -> pass + True -> throwError SSDoingRecovery + 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 epochSlots curSlot + - flattenSlotId epochSlots tipSlot + unless (slotDiff < fromIntegral lagBehindParam) $ + throwError + SSLagBehind + {sslbCurrentSlot = curSlot, sslbTipSlot = tipSlot} + where + recoveryIsInProgress = do + var <- view (lensOf @RecoveryHeaderTag) + isJust <$> atomically (STM.tryReadTMVar var) + convertRes :: Either SyncStatus () -> SyncStatus + convertRes (Left ss) = ss + convertRes (Right ()) = SSKindaSynced diff --git a/lib/src/Pos/WorkMode.hs b/lib/src/Pos/WorkMode.hs index 2690d4c6f27..552ffc1241a 100644 --- a/lib/src/Pos/WorkMode.hs +++ b/lib/src/Pos/WorkMode.hs @@ -148,9 +148,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 @@ -174,7 +172,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 d048586ef24..d56ab8a8fbd 100644 --- a/lib/src/Pos/Worker.hs +++ b/lib/src/Pos/Worker.hs @@ -14,7 +14,8 @@ import Pos.Worker.Block (blkWorkers) -- Message instances. import Pos.Chain.Txp (TxpConfiguration) import Pos.Context (NodeContext (..)) -import Pos.Crypto (ProtocolMagic) +import Pos.Core as Core (Config, configBlkSecurityParam, + configEpochSlots) import Pos.Infra.Diffusion.Types (Diffusion) import Pos.Infra.Network.CLI (launchStaticConfigMonitoring) import Pos.Infra.Network.Types (NetworkConfig (..)) @@ -28,19 +29,20 @@ import Pos.WorkMode (WorkMode) -- | All, but in reality not all, workers used by full node. allWorkers :: forall ext ctx m . WorkMode ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> NodeResources ext -> [Diffusion m -> m ()] -allWorkers pm txpConfig NodeResources {..} = mconcat - [ sscWorkers pm - , usWorkers - , blkWorkers pm txpConfig +allWorkers coreConfig txpConfig NodeResources {..} = mconcat + [ sscWorkers coreConfig + , usWorkers (configBlkSecurityParam coreConfig) + , blkWorkers coreConfig txpConfig , dlgWorkers , [properSlottingWorker, staticConfigMonitoringWorker] ] where topology = ncTopology ncNetworkConfig NodeContext {..} = nrContext - properSlottingWorker = const logNewSlotWorker + properSlottingWorker = + const $ logNewSlotWorker $ configEpochSlots coreConfig staticConfigMonitoringWorker = const (launchStaticConfigMonitoring topology) diff --git a/lib/src/Pos/Worker/Block.hs b/lib/src/Pos/Worker/Block.hs index 5600b1d14ed..f0d0d949cd4 100644 --- a/lib/src/Pos/Worker/Block.hs +++ b/lib/src/Pos/Worker/Block.hs @@ -29,18 +29,21 @@ import Pos.Chain.Block (HasBlockConfiguration, criticalCQ, scGlobalSlotMonitorState, scLocalSlotMonitorState) import Pos.Chain.Delegation (ProxySKBlockInfo) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Core (ChainDifficulty, FlatSlotId, HasProtocolConstants, - SlotId (..), Timestamp (Timestamp), addressHash, - blkSecurityParam, difficultyL, epochOrSlotToSlot, - epochSlots, flattenSlotId, getEpochOrSlot, - getOurPublicKey, getSlotIndex, slotIdF, unflattenSlotId) +import Pos.Core as Core (BlockCount, ChainDifficulty, Config (..), + FlatSlotId, SlotCount, SlotId (..), Timestamp (Timestamp), + addressHash, configBlkSecurityParam, configEpochSlots, + configSlotSecurityParam, difficultyL, epochOrSlotToSlot, + flattenSlotId, getEpochOrSlot, getOurPublicKey, + getSlotIndex, kEpochSlots, localSlotIndexFromEnum, + localSlotIndexMinBound, slotIdF, slotIdSucc, + unflattenSlotId) import Pos.Core.Chrono (OldestFirst (..)) import Pos.Core.Conc (delay) import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Core.Reporting (HasMisbehaviorMetrics, MetricMonitor (..), MetricMonitorState, noReportMonitor, recordValue) import Pos.Core.Update (BlockVersionData (..)) -import Pos.Crypto (ProtocolMagic, ProxySecretKey (pskDelegatePk)) +import Pos.Crypto (ProxySecretKey (pskDelegatePk)) import Pos.DB (gsIsBootstrapEra) import Pos.DB.Block (calcChainQualityFixedTime, calcChainQualityM, calcOverallChainQuality, createGenesisBlockAndApply, @@ -52,8 +55,8 @@ import Pos.DB.Update (getAdoptedBVData) 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 (reportOrLogE) import Pos.Infra.Slotting (ActionTerminationPolicy (..), OnNewSlotParams (..), currentTimeSlotting, @@ -76,33 +79,34 @@ blkWorkers :: ( BlockWorkMode ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> [Diffusion m -> m ()] -blkWorkers pm txpConfig = - [ blkCreatorWorker pm txpConfig - , informerWorker - , retrievalWorker pm txpConfig - , recoveryTriggerWorker pm +blkWorkers coreConfig txpConfig = + [ blkCreatorWorker coreConfig txpConfig + , informerWorker $ configBlkSecurityParam coreConfig + , retrievalWorker coreConfig txpConfig + , recoveryTriggerWorker coreConfig ] informerWorker - :: ( BlockWorkMode ctx m - ) => Diffusion m -> m () -informerWorker = - \_ -> onNewSlot defaultOnNewSlotParams $ \slotId -> - recoveryCommGuard "onNewSlot worker, informerWorker" $ do + :: 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 slotId + metricWorker k slotId where + epochSlots = kEpochSlots k logHowManySlotsBehind slotId tipHeader = let tipSlot = epochOrSlotToSlot (getEpochOrSlot tipHeader) - slotDiff = flattenSlotId slotId - flattenSlotId tipSlot + slotDiff = flattenSlotId epochSlots slotId - flattenSlotId epochSlots tipSlot in logInfo $ sformat ("Difference between current slot and tip slot is: " %int) slotDiff @@ -115,13 +119,15 @@ blkCreatorWorker :: ( BlockWorkMode ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> Diffusion m -> m () -blkCreatorWorker pm txpConfig = - \diffusion -> onNewSlot onsp $ \slotId -> - recoveryCommGuard "onNewSlot worker, blkCreatorWorker" $ - blockCreator pm txpConfig slotId diffusion `catchAny` onBlockCreatorException +blkCreatorWorker coreConfig txpConfig diffusion = + onNewSlot (configEpochSlots coreConfig) onsp $ \slotId -> + recoveryCommGuard (configBlkSecurityParam coreConfig) + "onNewSlot worker, blkCreatorWorker" + $ blockCreator coreConfig txpConfig slotId diffusion + `catchAny` onBlockCreatorException where onBlockCreatorException = reportOrLogE "blockCreator failed: " onsp :: OnNewSlotParams @@ -133,17 +139,17 @@ blockCreator :: ( BlockWorkMode ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> SlotId -> Diffusion m -> m () -blockCreator pm txpConfig (slotId@SlotId {..}) diffusion = do +blockCreator coreConfig txpConfig (slotId@SlotId {..}) diffusion = do -- First of all we create genesis block if necessary. - mGenBlock <- createGenesisBlockAndApply pm txpConfig siEpoch + mGenBlock <- createGenesisBlockAndApply coreConfig txpConfig siEpoch whenJust mGenBlock $ \createdBlk -> do logInfo $ sformat ("Created genesis block:\n" %build) createdBlk - jsonLog $ jlCreatedBlock (Left createdBlk) + jsonLog $ jlCreatedBlock (configEpochSlots coreConfig) (Left createdBlk) -- Then we get leaders for current epoch. leadersMaybe <- LrcDB.getLeadersForEpoch siEpoch @@ -160,8 +166,8 @@ blockCreator pm txpConfig (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 @@ -176,7 +182,7 @@ blockCreator pm txpConfig (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 @@ -192,22 +198,21 @@ blockCreator pm txpConfig (slotId@SlotId {..}) diffusion = do "delegated by heavy psk: "%build) ourHeavyPsk | weAreLeader -> - onNewSlotWhenLeader pm txpConfig slotId Nothing diffusion + onNewSlotWhenLeader coreConfig txpConfig slotId Nothing diffusion | heavyWeAreDelegate -> let pske = swap <$> dlgTransM - in onNewSlotWhenLeader pm txpConfig slotId pske diffusion + in onNewSlotWhenLeader coreConfig txpConfig slotId pske diffusion | otherwise -> pass onNewSlotWhenLeader - :: ( BlockWorkMode ctx m - ) - => ProtocolMagic + :: BlockWorkMode ctx m + => Core.Config -> TxpConfiguration -> SlotId -> ProxySKBlockInfo -> Diffusion m -> m () -onNewSlotWhenLeader pm txpConfig slotId pske diffusion = do +onNewSlotWhenLeader coreConfig txpConfig slotId pske diffusion = do let logReason = sformat ("I have a right to create a block for the slot "%slotIdF%" ") slotId @@ -215,7 +220,8 @@ onNewSlotWhenLeader pm txpConfig 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 (configEpochSlots coreConfig) slotId) currentTime <- currentTimeSlotting let timeToCreate = max currentTime (nextSlotStart - Timestamp networkDiameter) @@ -227,13 +233,13 @@ onNewSlotWhenLeader pm txpConfig slotId pske diffusion = do where onNewSlotWhenLeaderDo = do logInfoS "It's time to create a block for current slot" - createdBlock <- createMainBlockAndApply pm txpConfig slotId pske + createdBlock <- createMainBlockAndApply coreConfig txpConfig 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 (configEpochSlots coreConfig) (Right createdBlk) void $ Diffusion.announceBlockHeader diffusion $ createdBlk ^. gbHeader whenNotCreated = logWarningS . (mappend "I couldn't create a new block: ") @@ -245,18 +251,19 @@ recoveryTriggerWorker :: forall ctx m. ( BlockWorkMode ctx m ) - => ProtocolMagic -> Diffusion m -> m () -recoveryTriggerWorker pm diffusion = do + => Core.Config -> Diffusion m -> m () +recoveryTriggerWorker coreConfig 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 (configSlotSecurityParam coreConfig) when doTrigger $ do logInfo "Triggering recovery because we need it" - triggerRecovery pm diffusion + triggerRecovery coreConfig diffusion -- Sometimes we want to trigger recovery just in case. Maybe -- we're just 5 slots late, but nobody wants to send us @@ -269,9 +276,9 @@ recoveryTriggerWorker pm diffusion = do 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 coreConfig diffusion -- We don't want to ask for tips too frequently. -- E.g. there may be a tip processing mistake so that we @@ -281,6 +288,7 @@ recoveryTriggerWorker pm diffusion = do -- will minimize risks and network load. when (doTrigger || triggerSafety) $ delay (20 :: Second) where + epochSlots = configEpochSlots coreConfig repeatOnInterval action = void $ do delay (1 :: Second) -- REPORT:ERROR 'reportOrLogE' in recovery trigger worker @@ -303,12 +311,12 @@ recoveryTriggerWorker pm diffusion = do -- Apart from chain quality check we also record some generally useful values. metricWorker :: BlockWorkMode ctx m - => SlotId -> m () -metricWorker curSlot = do + => 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. @@ -317,8 +325,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 @@ -337,8 +345,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 <- @@ -351,20 +359,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 = @@ -377,30 +384,34 @@ reportCrucialValues = do chainQualityChecker :: ( BlockWorkMode ctx m ) - => SlotId + => BlockCount + -> SlotId -> FlatSlotId -> m () -chainQualityChecker curSlot kThSlot = do +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 @@ -429,7 +440,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/lib/src/Pos/Worker/Ssc.hs b/lib/src/Pos/Worker/Ssc.hs index a9cf043d46d..0dd93ad3ae7 100644 --- a/lib/src/Pos/Worker/Ssc.hs +++ b/lib/src/Pos/Worker/Ssc.hs @@ -32,10 +32,11 @@ import Pos.Chain.Ssc (HasSscConfiguration, HasSscContext (..), isSharesIdx, mkSignedCommitment, mpcSendInterval, scBehavior, scParticipateSsc, scVssKeyPair, sgsCommitments, vssThreshold) -import Pos.Core (EpochIndex, HasPrimaryKey, SlotId (..), - StakeholderId, Timestamp (..), blkSecurityParam, +import Pos.Core as Core (BlockCount, Config (..), EpochIndex, + HasPrimaryKey, SlotId (..), StakeholderId, Timestamp (..), + configBlkSecurityParam, configEpochSlots, configVssMaxTTL, getOurSecretKey, getOurStakeholderId, getSlotIndex, - mkLocalSlotIndex, slotSecurityParam, vssMaxTTL) + kEpochSlots, kSlotSecurityParam, mkLocalSlotIndex) import Pos.Core.Conc (currentTime, delay) import Pos.Core.JsonLog (CanJsonLog) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), @@ -45,9 +46,8 @@ import Pos.Core.Ssc (InnerSharesMap, Opening, SignedCommitment, getCommitmentsMap, lookupVss, memberVss, mkVssCertificate, randCommitmentAndOpening) import Pos.Core.Update (bvdMpcThd) -import Pos.Crypto (ProtocolMagic, SecretKey, VssKeyPair, VssPublicKey, - randomNumber, randomNumberInRange, runSecureRandom, - vssKeyGen) +import Pos.Crypto (SecretKey, VssKeyPair, VssPublicKey, randomNumber, + randomNumberInRange, runSecureRandom, vssKeyGen) import Pos.Crypto.SecretSharing (toVssPublicKey) import Pos.DB (gsAdoptedBVData) import Pos.DB.Class (MonadDB, MonadGState) @@ -95,8 +95,12 @@ sscWorkers :: ( SscMode ctx m , HasMisbehaviorMetrics ctx ) - => ProtocolMagic -> [Diffusion m -> m ()] -sscWorkers pm = [onNewSlotSsc pm, checkForIgnoredCommitmentsWorker] + => Core.Config + -> [Diffusion m -> m ()] +sscWorkers coreConfig = + [ onNewSlotSsc coreConfig + , checkForIgnoredCommitmentsWorker (configBlkSecurityParam coreConfig) + ] shouldParticipate :: SscMode ctx m => EpochIndex -> m Bool shouldParticipate epoch = do @@ -112,32 +116,30 @@ shouldParticipate epoch = do -- CHECK: @onNewSlotSsc -- #checkNSendOurCert onNewSlotSsc - :: ( SscMode ctx m - ) - => ProtocolMagic + :: SscMode ctx m + => Core.Config -> Diffusion m -> m () -onNewSlotSsc pm = \diffusion -> onNewSlot defaultOnNewSlotParams $ \slotId -> - recoveryCommGuard "onNewSlot worker in SSC" $ do +onNewSlotSsc coreConfig diffusion = onNewSlot (configEpochSlots coreConfig) defaultOnNewSlotParams $ \slotId -> + recoveryCommGuard (configBlkSecurityParam coreConfig) "onNewSlot worker in SSC" $ do sscGarbageCollectLocalData slotId whenM (shouldParticipate $ siEpoch slotId) $ do behavior <- view sscContext >>= (readTVarIO . scBehavior) - checkNSendOurCert pm (sendSscCert diffusion) - onNewSlotCommitment pm slotId (sendSscCommitment diffusion) - onNewSlotOpening pm (sbSendOpening behavior) slotId (sendSscOpening diffusion) - onNewSlotShares pm (sbSendShares behavior) slotId (sendSscShares diffusion) + checkNSendOurCert coreConfig (sendSscCert diffusion) + onNewSlotCommitment coreConfig slotId (sendSscCommitment diffusion) + onNewSlotOpening coreConfig (sbSendOpening behavior) slotId (sendSscOpening diffusion) + onNewSlotShares coreConfig (sbSendShares behavior) slotId (sendSscShares diffusion) -- CHECK: @checkNSendOurCert -- Checks whether 'our' VSS certificate has been announced checkNSendOurCert :: forall ctx m. - ( SscMode ctx m - ) - => ProtocolMagic + SscMode ctx m + => Core.Config -> (VssCertificate -> m ()) -> m () -checkNSendOurCert pm sendCert = do +checkNSendOurCert coreConfig sendCert = do ourId <- getOurStakeholderId let sendCertDo resend slot = do if resend then @@ -147,11 +149,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 coreConfig ourVssCertificate) _ <- sendCert ourVssCertificate logDebugS "Announced our VssCertificate." - slMaybe <- getCurrentSlot + slMaybe <- getCurrentSlot $ configEpochSlots coreConfig case slMaybe of Nothing -> pass Just sl -> do @@ -180,8 +182,8 @@ checkNSendOurCert pm sendCert = do ourVssKeyPair <- getOurVssKeyPair let vssKey = asBinary $ toVssPublicKey ourVssKeyPair createOurCert = - mkVssCertificate pm ourSk vssKey . - (+) (vssMaxTTL - 1) . siEpoch + mkVssCertificate (configProtocolMagic coreConfig) ourSk vssKey . + (+) (configVssMaxTTL coreConfig - 1) . siEpoch return $ createOurCert slot getOurVssKeyPair :: SscMode ctx m => m VssKeyPair @@ -189,19 +191,18 @@ getOurVssKeyPair = views sscContext scVssKeyPair -- Commitments-related part of new slot processing onNewSlotCommitment - :: ( SscMode ctx m - ) - => ProtocolMagic + :: SscMode ctx m + => Core.Config -> SlotId -> (SignedCommitment -> m ()) -> m () -onNewSlotCommitment pm slotId@SlotId {..} sendCommitment - | not (isCommitmentIdx siSlot) = pass +onNewSlotCommitment coreConfig 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 @@ -213,10 +214,12 @@ onNewSlotCommitment pm slotId@SlotId {..} sendCommitment Just comm -> logDebugS stillValidMsg >> sendOurCommitment comm Nothing -> onNewSlotCommDo where + k = configBlkSecurityParam coreConfig + onNewSlotCommDo = do ourSk <- getOurSecretKey logDebugS $ sformat ("Generating secret for "%ords%" epoch") siEpoch - generated <- generateAndSetNewSecret pm ourSk slotId + generated <- generateAndSetNewSecret coreConfig ourSk slotId case generated of Nothing -> logWarningS "I failed to generate secret for SSC" Just comm -> do @@ -224,8 +227,8 @@ onNewSlotCommitment pm slotId@SlotId {..} sendCommitment sendOurCommitment comm sendOurCommitment comm = do - sscProcessOurMessage (sscProcessCommitment pm comm) - sendOurData sendCommitment CommitmentMsg comm siEpoch 0 + sscProcessOurMessage (sscProcessCommitment coreConfig comm) + sendOurData k sendCommitment CommitmentMsg comm siEpoch 0 -- | Generate a random Opening. randomOpening :: IO Opening @@ -239,17 +242,16 @@ randomOpening = snd <$> secureRandCommitmentAndOpening -- Openings-related part of new slot processing onNewSlotOpening - :: ( SscMode ctx m - ) - => ProtocolMagic + :: SscMode ctx m + => Core.Config -> SscOpeningParams -- ^ This parameter is part of the node's -- BehaviorConfig which defines how the node should -- behave when it's sending openings to other nodes -> SlotId -> (Opening -> m ()) -> m () -onNewSlotOpening pm params SlotId {..} sendOpening - | not $ isOpeningIdx siSlot = pass +onNewSlotOpening coreConfig params SlotId {..} sendOpening + | not $ isOpeningIdx k siSlot = pass | otherwise = do ourId <- getOurStakeholderId globalData <- sscGetGlobalState @@ -260,6 +262,8 @@ onNewSlotOpening pm params SlotId {..} sendOpening Nothing -> logWarningS noOpenMsg Just open -> sendOpeningDo ourId open where + k = configBlkSecurityParam coreConfig + noCommMsg = "We're not sending opening, because there is no commitment \ \from us in global state" @@ -275,28 +279,28 @@ onNewSlotOpening pm params SlotId {..} sendOpening -- typically only specified for testing purposes. SscOpeningWrong -> Just <$> liftIO randomOpening whenJust mbOpen' $ \open' -> do - sscProcessOurMessage (sscProcessOpening pm ourId open') - sendOurData sendOpening OpeningMsg open' siEpoch 2 + sscProcessOurMessage (sscProcessOpening coreConfig ourId open') + sendOurData k sendOpening OpeningMsg open' siEpoch 2 -- Shares-related part of new slot processing onNewSlotShares - :: ( SscMode ctx m - ) - => ProtocolMagic + :: SscMode ctx m + => Core.Config -> SscSharesParams -> SlotId -> (InnerSharesMap -> m ()) -> m () -onNewSlotShares pm params SlotId {..} sendShares = do +onNewSlotShares coreConfig 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 = configBlkSecurityParam coreConfig sendSharesDo ourId shares = do let shares' = case params of SscSharesNone -> mempty @@ -309,8 +313,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 coreConfig ourId lShares) + sendOurData k sendShares SharesMsg lShares siEpoch 4 sscProcessOurMessage :: (Buildable err, SscMode ctx m) @@ -325,17 +329,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 @@ -347,16 +352,15 @@ 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 - ) - => ProtocolMagic + :: forall ctx m + . SscMode ctx m + => Core.Config -> SecretKey -> SlotId -- ^ Current slot -> m (Maybe SignedCommitment) -generateAndSetNewSecret pm sk SlotId {..} = do +generateAndSetNewSecret coreConfig sk SlotId {..} = do richmen <- getSscRichmen "generateAndSetNewSecret" siEpoch - certs <- getStableCerts siEpoch + certs <- getStableCerts (configBlkSecurityParam coreConfig) siEpoch inAssertMode $ do let participantIds = HM.keys . getVssCertificatesMap $ @@ -396,7 +400,11 @@ generateAndSetNewSecret pm sk SlotId {..} = do Right keys -> do (comm, open) <- liftIO $ runSecureRandom $ randCommitmentAndOpening threshold keys - let signedComm = mkSignedCommitment pm sk siEpoch comm + let signedComm = mkSignedCommitment + (configProtocolMagic coreConfig) + sk + siEpoch + comm SS.putOurSecret signedComm open siEpoch pure (Just signedComm) @@ -412,11 +420,11 @@ randomTimeInInterval interval = waitUntilSend :: SscMode ctx m - => SscTag -> EpochIndex -> Word16 -> m () -waitUntilSend msgTag epoch slMultiplier = do + => BlockCount -> SscTag -> EpochIndex -> Word16 -> m () +waitUntilSend k msgTag epoch slMultiplier = do let slot = leftToPanic "waitUntilSend: " $ - mkLocalSlotIndex $ slMultiplier * fromIntegral slotSecurityParam + mkLocalSlotIndex (kEpochSlots k) $ slMultiplier * fromIntegral (kSlotSecurityParam k) Timestamp beginning <- getSlotStartEmpatically $ SlotId {siEpoch = epoch, siSlot = slot} @@ -444,11 +452,14 @@ checkForIgnoredCommitmentsWorker ( SscMode ctx m , HasMisbehaviorMetrics ctx ) - => Diffusion m + => 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 @@ -464,12 +475,12 @@ checkForIgnoredCommitmentsWorkerImpl ( SscMode ctx m , HasMisbehaviorMetrics ctx ) - => TVar Word -> SlotId -> m () -checkForIgnoredCommitmentsWorkerImpl counter SlotId {..} + => 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/lib/src/Pos/Worker/Update.hs b/lib/src/Pos/Worker/Update.hs index 8753b536787..9c154133bd0 100644 --- a/lib/src/Pos/Worker/Update.hs +++ b/lib/src/Pos/Worker/Update.hs @@ -13,6 +13,7 @@ import Serokell.Util.Text (listJsonIndent) import Pos.Chain.Update (ConfirmedProposalState (..), curSoftwareVersion) +import Pos.Core (BlockCount, kEpochSlots) import Pos.Core.Update (SoftwareVersion (..), UpdateProposal (..)) import Pos.DB.Update (UpdateContext (..), getConfirmedProposals, processNewSlot) @@ -28,26 +29,23 @@ import Pos.Util.Wlog (logDebug, logInfo) -- | 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/lib/test/Test/Pos/Block/Arbitrary/Message.hs b/lib/test/Test/Pos/Block/Arbitrary/Message.hs index 0b0e7cd73e5..eb5b2b71167 100644 --- a/lib/test/Test/Pos/Block/Arbitrary/Message.hs +++ b/lib/test/Test/Pos/Block/Arbitrary/Message.hs @@ -11,7 +11,7 @@ import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, genericShrink) -import Pos.Core (HasGenesisHash, HasProtocolConstants) +import Pos.Core (HasGenesisHash) import qualified Pos.Network.Block.Types as T import Test.Pos.Chain.Block.Arbitrary () @@ -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/lib/test/Test/Pos/Cbor/CborSpec.hs b/lib/test/Test/Pos/Cbor/CborSpec.hs index 76c886aaf4b..94912dc47a6 100644 --- a/lib/test/Test/Pos/Cbor/CborSpec.hs +++ b/lib/test/Test/Pos/Cbor/CborSpec.hs @@ -51,7 +51,6 @@ import Test.Pos.Cbor.Arbitrary.UserSecret () import Test.Pos.Chain.Delegation.Arbitrary () import Test.Pos.Chain.Ssc.Arbitrary () import Test.Pos.Chain.Update.Arbitrary () -import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.Core.Arbitrary () import Test.Pos.Crypto.Arbitrary () import Test.Pos.DB.Update.Arbitrary () @@ -68,7 +67,7 @@ type UpId' = Tagged (U.UpdateProposal, [U.UpdateVote])U.UpId ---------------------------------------- spec :: Spec -spec = withDefConfiguration $ \_ -> do +spec = 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 13cc0b3bbf9..e373f8144c4 100644 --- a/lib/test/Test/Pos/Diffusion/BlockSpec.hs +++ b/lib/test/Test/Pos/Diffusion/BlockSpec.hs @@ -232,7 +232,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 = [] @@ -292,4 +292,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/Toss/BaseSpec.hs b/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs index cd3a45697a8..3a394f5b87b 100644 --- a/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs +++ b/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs @@ -47,6 +47,7 @@ import Test.Pos.Util.QuickCheck.Property (qcElem, qcFail, qcIsRight) import Test.Pos.Chain.Ssc.Arbitrary (BadCommAndOpening (..), BadSignedCommitment (..), CommitmentOpening (..)) import Test.Pos.Configuration (withDefConfiguration) +import Test.Pos.Core.Dummy (dummyK) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) spec :: Spec @@ -69,7 +70,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 @@ -159,7 +160,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 @@ -198,7 +199,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 @@ -217,7 +218,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 @@ -237,7 +238,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 @@ -247,7 +248,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 @@ -266,7 +267,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 @@ -397,7 +398,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 @@ -428,7 +429,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 @@ -457,11 +458,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 <> @@ -469,7 +470,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 <> @@ -485,7 +486,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 6f919538cfb..bd481d995a4 100644 --- a/lib/test/Test/Pos/Ssc/Toss/PureSpec.hs +++ b/lib/test/Test/Pos/Ssc/Toss/PureSpec.hs @@ -52,7 +52,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 52ce4e33980..dd16f42bc97 100644 --- a/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs +++ b/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs @@ -24,7 +24,7 @@ import Pos.Chain.Ssc (SscGlobalState (..), VssCertData (..), sgsVssCertificates) import qualified Pos.Chain.Ssc as Ssc import Pos.Core (EpochIndex (..), EpochOrSlot (..), HasConfiguration, - SlotId (..), slotSecurityParam) + SlotId (..)) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Slotting (flattenEpochOrSlot, unflattenSlotId) import Pos.Core.Ssc (VssCertificate (..), getCertId, @@ -32,6 +32,7 @@ import Pos.Core.Ssc (VssCertificate (..), getCertId, 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.Infra.Arbitrary.Ssc () import Test.Pos.Util.QuickCheck.Property (qcIsJust) @@ -181,14 +182,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 <$> @@ -197,15 +198,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 Ssc.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/Identity/SafeCopySpec.hs b/lib/test/Test/Pos/Types/Identity/SafeCopySpec.hs index d62a489efe3..65ca201874f 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.Ssc as Ssc import qualified Pos.Core.Txp as Txp import Test.Pos.Binary.Helpers (safeCopyTest) -import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.Core.Arbitrary.Txp () import Test.Pos.Infra.Arbitrary.Txp () 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 c2555a93776..44a1efb6e5a 100644 --- a/lib/test/Test/Pos/Update/PollSpec.hs +++ b/lib/test/Test/Pos/Update/PollSpec.hs @@ -19,7 +19,7 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, import Pos.Chain.Update (applyBVM) import qualified Pos.Chain.Update as Poll -import Pos.Core (HasConfiguration, StakeholderId, addressHash) +import Pos.Core (StakeholderId, addressHash) import Pos.Core.Update (ApplicationName, BlockVersion (..), BlockVersionData (..), SoftwareVersion (..), UpId, UpdateProposal (..)) @@ -30,12 +30,11 @@ import qualified Pos.Util.Modifier as MM import Test.Pos.Binary.Helpers () import Test.Pos.Chain.Update.Arbitrary () -import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.DB.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 @@ -95,7 +94,7 @@ data PollAction | SetEpochProposers (HashSet StakeholderId) deriving (Show, Eq, Generic) -instance HasConfiguration => Arbitrary PollAction where +instance Arbitrary PollAction where arbitrary = genericArbitrary shrink = genericShrink @@ -196,8 +195,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 @@ -239,8 +237,7 @@ property will cause it to fail. -} putDelBVState - :: HasConfiguration - => BlockVersion + :: BlockVersion -> Poll.BlockVersionState -> PollStateTestInfo -> Property @@ -251,8 +248,7 @@ putDelBVState bv bvs = in ([PutBVState bv bvs, DelBVState bv] ==^ []) actionPrefixGen setDeleteConfirmedSV - :: HasConfiguration - => SoftwareVersion + :: SoftwareVersion -> PollStateTestInfo -> Property setDeleteConfirmedSV sv = @@ -263,8 +259,7 @@ setDeleteConfirmedSV sv = in ([SetLastConfirmedSV sv, DelConfirmedSV appName] ==^ []) actionPrefixGen addDeleteConfirmedProposal - :: HasConfiguration - => Poll.ConfirmedProposalState + :: Poll.ConfirmedProposalState -> PollStateTestInfo -> Property addDeleteConfirmedProposal cps = @@ -276,8 +271,7 @@ addDeleteConfirmedProposal cps = []) actionPrefixGen insertDeleteProposal - :: HasConfiguration - => Poll.ProposalState + :: Poll.ProposalState -> PollStateTestInfo -> Property insertDeleteProposal ps = diff --git a/node/Main.hs b/node/Main.hs index 39d1855d1ac..529fcb2db45 100644 --- a/node/Main.hs +++ b/node/Main.hs @@ -22,7 +22,6 @@ import Pos.Client.CLI (CommonNodeArgs (..), NodeArgs (..), SimpleNodeArgs (..)) import qualified Pos.Client.CLI as CLI import Pos.Core as Core (Config (..)) -import Pos.Crypto (ProtocolMagic) import Pos.Launcher (HasConfigurations, NodeParams (..), loggerBracket, runNodeReal, withConfigurations) import Pos.Launcher.Configuration (AssetLockPath (..)) @@ -39,13 +38,13 @@ actionWithoutWallet :: ( HasConfigurations , HasCompileInfo ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> SscParams -> NodeParams -> IO () -actionWithoutWallet pm txpConfig sscParams nodeParams = - runNodeReal pm txpConfig nodeParams sscParams [updateTriggerWorker] +actionWithoutWallet coreConfig txpConfig sscParams nodeParams = + runNodeReal coreConfig txpConfig nodeParams sscParams [updateTriggerWorker] action :: ( HasConfigurations @@ -67,10 +66,7 @@ action (SimpleNodeArgs (cArgs@CommonNodeArgs {..}) (nArgs@NodeArgs {..})) coreCo let vssSK = fromJust $ npUserSecret currentParams ^. usVss let sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig currentParams) - actionWithoutWallet (configProtocolMagic coreConfig) - txpConfig - sscParams - currentParams + actionWithoutWallet coreConfig txpConfig sscParams currentParams main :: IO () main = withCompileInfo $ do diff --git a/pkgs/default.nix b/pkgs/default.nix index 0aad33aeb89..e21e0f65975 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -15566,6 +15566,7 @@ license = stdenv.lib.licenses.mit; , cardano-sl , cardano-sl-chain , cardano-sl-core +, cardano-sl-core-test , cardano-sl-crypto , cardano-sl-crypto-test , cardano-sl-db @@ -15631,6 +15632,7 @@ bytestring cardano-sl cardano-sl-chain cardano-sl-core +cardano-sl-core-test cardano-sl-crypto cardano-sl-crypto-test cardano-sl-db @@ -16331,6 +16333,7 @@ cardano-sl-binary cardano-sl-chain cardano-sl-chain-test cardano-sl-core +cardano-sl-core-test cardano-sl-crypto cardano-sl-crypto-test cardano-sl-db @@ -17755,6 +17758,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-infra , cardano-sl-networking @@ -17986,6 +17990,7 @@ cardano-sl-client cardano-sl-core cardano-sl-core-test cardano-sl-crypto +cardano-sl-crypto-test cardano-sl-db cardano-sl-networking cardano-sl-util diff --git a/ssc/src/Pos/Ssc/Toss/Trans.hs b/ssc/src/Pos/Ssc/Toss/Trans.hs new file mode 100644 index 00000000000..72e16dde954 --- /dev/null +++ b/ssc/src/Pos/Ssc/Toss/Trans.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | TossT monad transformer. Single-threaded. + +module Pos.Ssc.Toss.Trans + ( TossT + , runTossT + , evalTossT + , execTossT + ) where + +import Universum hiding (id) + +import Control.Lens (at, (%=), (.=)) +import qualified Ether +import Mockable (ChannelT, Promise, SharedAtomicT, ThreadId) + +import Pos.Core.Ssc (insertVss) +import Pos.Ssc.Base (deleteSignedCommitment, insertSignedCommitment) +import Pos.Ssc.Toss.Class (MonadToss (..), MonadTossEnv (..), + MonadTossRead (..)) +import Pos.Ssc.Toss.Types (TossModifier (..), tmCertificates, + tmCommitments, tmOpenings, tmShares) +import Pos.Util.Util (ether) + +---------------------------------------------------------------------------- +-- Tranformer +---------------------------------------------------------------------------- + +-- | Monad transformer which stores TossModifier and implements +-- writable MonadToss. +-- +-- [WARNING] This transformer uses StateT and is intended for +-- single-threaded usage only. +type TossT = Ether.StateT' TossModifier + +---------------------------------------------------------------------------- +-- Runners +---------------------------------------------------------------------------- + +runTossT :: TossModifier -> TossT m a -> m (a, TossModifier) +runTossT = flip Ether.runStateT + +evalTossT :: Monad m => TossModifier -> TossT m a -> m a +evalTossT = flip Ether.evalStateT + +execTossT :: Monad m => TossModifier -> TossT m a -> m TossModifier +execTossT = flip Ether.execStateT + +---------------------------------------------------------------------------- +-- MonadToss +---------------------------------------------------------------------------- + +instance MonadTossRead m => + MonadTossRead (TossT m) where + getCommitments = ether $ (<>) <$> use tmCommitments <*> getCommitments + getOpenings = ether $ (<>) <$> use tmOpenings <*> getOpenings + getShares = ether $ (<>) <$> use tmShares <*> getShares + getVssCertificates = ether $ (<>) <$> use tmCertificates <*> getVssCertificates + getStableCertificates pc = ether . getStableCertificates pc + +instance MonadTossEnv m => + MonadTossEnv (TossT m) where + getRichmen = ether . getRichmen + getAdoptedBVData = ether getAdoptedBVData + +instance MonadToss m => + MonadToss (TossT m) where + putCommitment signedComm = + ether $ tmCommitments %= insertSignedCommitment signedComm + putOpening id op = + ether $ tmOpenings . at id .= Just op + putShares id sh = + ether $ tmShares . at id .= Just sh + -- NB. 'insertVss' might delete some certs from the map, but it + -- shouldn't actually happen in practice because + -- 'checkCertificatesPayload' ensures that there are no clashes between + -- the certificates in blocks and certificates in the map + putCertificate cert = + ether $ tmCertificates %= fst . insertVss cert + delCommitment id = + ether $ tmCommitments %= deleteSignedCommitment id + delOpening id = + ether $ tmOpenings . at id .= Nothing + delShares id = + ether $ tmShares . at id .= Nothing + resetCO = ether $ do + tmCommitments .= mempty + tmOpenings .= mempty + tmCertificates .= mempty + resetCO + resetShares = ether $ do + tmShares .= mempty + resetShares + setEpochOrSlot = ether . setEpochOrSlot + +---------------------------------------------------------------------------- +-- Common instances used all over the code +---------------------------------------------------------------------------- + +type instance ThreadId (TossT m) = ThreadId m +type instance Promise (TossT m) = Promise m +type instance SharedAtomicT (TossT m) = SharedAtomicT m +type instance ChannelT (TossT m) = ChannelT m diff --git a/ssc/src/Pos/Ssc/Toss/Types.hs b/ssc/src/Pos/Ssc/Toss/Types.hs new file mode 100644 index 00000000000..8ceb65c4150 --- /dev/null +++ b/ssc/src/Pos/Ssc/Toss/Types.hs @@ -0,0 +1,91 @@ +-- | Types related to Toss. + +module Pos.Ssc.Toss.Types + ( SscTag (..) + , isGoodSlotForTag + , isGoodSlotIdForTag + + , TossModifier (..) + , tmCommitments + , tmOpenings + , tmShares + , tmCertificates + ) where + +import Control.Lens (makeLenses) +import qualified Data.Text.Buildable as Buildable +import Universum + +import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi, + deriveSimpleBiCxt) +import Pos.Core (BlockCount, LocalSlotIndex, SlotId, + VssCertificatesMap) +import Pos.Core.Ssc (CommitmentsMap, OpeningsMap, SharesMap) +import Pos.Ssc.Base (isCommitmentId, isCommitmentIdx, isOpeningId, + isOpeningIdx, isSharesId, isSharesIdx) +import Pos.Util.Util (cborError) + +-- | Tag corresponding to SSC data. +data SscTag + = CommitmentMsg + | OpeningMsg + | SharesMsg + | VssCertificateMsg + deriving (Show, Eq, Generic) + +instance Buildable SscTag where + build CommitmentMsg = "commitment" + build OpeningMsg = "opening" + build SharesMsg = "shares" + build VssCertificateMsg = "VSS certificate" + +deriveSimpleBi ''SscTag [ + Cons 'CommitmentMsg [], + Cons 'OpeningMsg [], + Cons 'SharesMsg [], + Cons 'VssCertificateMsg []] + +isGoodSlotIdForTag :: BlockCount -> SscTag -> SlotId -> Bool +isGoodSlotIdForTag k = \case + CommitmentMsg -> isCommitmentId k + OpeningMsg -> isOpeningId k + SharesMsg -> isSharesId k + VssCertificateMsg -> const True + +isGoodSlotForTag :: BlockCount -> SscTag -> LocalSlotIndex -> Bool +isGoodSlotForTag k = \case + CommitmentMsg -> isCommitmentIdx k + OpeningMsg -> isOpeningIdx k + SharesMsg -> isSharesIdx k + VssCertificateMsg -> const True + +data TossModifier = TossModifier + { _tmCommitments :: !CommitmentsMap + , _tmOpenings :: !OpeningsMap + , _tmShares :: !SharesMap + , _tmCertificates :: !VssCertificatesMap + } deriving (Generic, Show, Eq) + +makeLenses ''TossModifier + +instance Semigroup TossModifier where + (TossModifier leftComms leftOpens leftShares leftCerts) + <> (TossModifier rightComms rightOpens rightShares rightCerts) = + TossModifier + { _tmCommitments = rightComms <> leftComms + , _tmOpenings = rightOpens <> leftOpens + , _tmShares = rightShares <> leftShares + , _tmCertificates = rightCerts <> leftCerts + } + +instance Monoid TossModifier where + mempty = TossModifier mempty mempty mempty mempty + mappend = (<>) + +deriveSimpleBiCxt [t|()|] ''TossModifier [ + Cons 'TossModifier [ + Field [| _tmCommitments :: CommitmentsMap |], + Field [| _tmOpenings :: OpeningsMap |], + Field [| _tmShares :: SharesMap |], + Field [| _tmCertificates :: VssCertificatesMap |] + ]] diff --git a/tools/src/dbgen/Main.hs b/tools/src/dbgen/Main.hs index faf08343492..196009b9bae 100644 --- a/tools/src/dbgen/Main.hs +++ b/tools/src/dbgen/Main.hs @@ -22,7 +22,8 @@ import Options.Generic (getRecord) import Pos.Chain.Txp (TxpConfiguration) import Pos.Client.CLI (CommonArgs (..), CommonNodeArgs (..), NodeArgs (..), getNodeParams, gtSscParams) -import Pos.Core as Core (Config (..), Timestamp (..), epochSlots) +import Pos.Core as Core (Config (..), Timestamp (..), + configBlkSecurityParam) import Pos.DB.DB (initNodeDBs) import Pos.DB.Rocks.Functions (openNodeDBs) import Pos.DB.Rocks.Types (NodeDBs) @@ -115,7 +116,12 @@ newRealModeContext coreConfig txpConfig dbs confOpts publicKeyPath secretKeyPath (configGeneratedSecrets coreConfig) let vssSK = fromJust $ npUserSecret nodeParams ^. usVss let gtParams = gtSscParams cArgs vssSK (npBehaviorConfig nodeParams) - bracketNodeResources @() nodeParams gtParams (txpGlobalSettings pm txpConfig) (initNodeDBs pm epochSlots) $ \NodeResources{..} -> + bracketNodeResources @() + (configBlkSecurityParam coreConfig) + nodeParams + gtParams + (txpGlobalSettings (configProtocolMagic coreConfig) txpConfig) + (initNodeDBs coreConfig) $ \NodeResources{..} -> RealModeContext <$> pure dbs <*> pure nrSscState <*> pure nrTxpState @@ -125,8 +131,6 @@ newRealModeContext coreConfig txpConfig dbs confOpts publicKeyPath secretKeyPath <*> pure nrContext <*> pure noReporter -- <*> initQueue (defaultNetworkConfig (TopologyAuxx mempty)) Nothing - where - pm = configProtocolMagic coreConfig walletRunner :: HasConfigurations @@ -167,7 +171,7 @@ main = do cli@CLI{..} <- getRecord "DBGen" let cfg = newConfig cli - withConfigurations Nothing cfg $ \pm txpConfig _ -> do + withConfigurations Nothing cfg $ \coreConfig txpConfig _ -> do when showStats (showStatsAndExit walletPath) say $ bold "Starting the modification of the wallet..." @@ -179,7 +183,7 @@ main = do ws <- newWalletState (isJust addTo) walletPath -- Recreate or not let generatedWallet = generateWalletDB cli spec - walletRunner pm txpConfig cfg dbs publicKeyPath secretKeyPath ws generatedWallet + walletRunner coreConfig txpConfig cfg dbs publicKeyPath secretKeyPath ws generatedWallet closeState ws showStatsData "after" walletPath diff --git a/tools/src/keygen/Main.hs b/tools/src/keygen/Main.hs index 4cd2a8f6229..553ac8b039c 100644 --- a/tools/src/keygen/Main.hs +++ b/tools/src/keygen/Main.hs @@ -17,10 +17,10 @@ import qualified Text.JSON.Canonical as CanonicalJSON import Pos.Binary (asBinary, serialize') import qualified Pos.Client.CLI as CLI -import Pos.Core (Config (..), CoreConfiguration (..), - GenesisConfiguration (..), ProtocolMagic, addressHash, - ccGenesis, configGeneratedSecretsThrow, coreConfiguration, - vssMaxTTL) +import Pos.Core as Core (Config (..), CoreConfiguration (..), + GenesisConfiguration (..), addressHash, ccGenesis, + configGeneratedSecretsThrow, configVssMaxTTL, + coreConfiguration) import Pos.Core.Genesis (GeneratedSecrets (..), RichSecrets (..), generateFakeAvvm, generateRichSecrets) import Pos.Core.Ssc (mkVssCertificate, vcSigningKey) @@ -134,17 +134,19 @@ generateKeysByGenesis generatedSecrets GenKeysOptions{..} = do logInfo (toText gkoOutDir <> " generated successfully") genVssCert - :: (HasConfigurations, WithLogger m, MonadIO m) - => ProtocolMagic -> FilePath -> m () -genVssCert pm path = do + :: (WithLogger m, MonadIO m) + => Core.Config + -> FilePath + -> m () +genVssCert coreConfig path = do us <- readUserSecret path let primKey = fromMaybe (error "No primary key") (us ^. usPrimKey) vssKey = fromMaybe (error "No VSS key") (us ^. usVss) let cert = mkVssCertificate - pm + (configProtocolMagic coreConfig) primKey (asBinary (toVssPublicKey vssKey)) - (vssMaxTTL - 1) + (configVssMaxTTL coreConfig - 1) putText $ sformat ("JSON: key "%hashHexF%", value "%stext) (addressHash $ vcSigningKey cert) (decodeUtf8 $ @@ -168,8 +170,7 @@ main = do case koCommand of RearrangeMask msk -> rearrange msk GenerateKey path -> genPrimaryKey path - GenerateVss path -> - genVssCert (configProtocolMagic coreConfig) path + GenerateVss path -> genVssCert coreConfig path ReadKey path -> readKey path DumpAvvmSeeds opts -> dumpAvvmSeeds opts GenerateKeysBySpec gkbg -> diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index 01365e9c972..f6164c3b641 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -496,6 +496,7 @@ test-suite wallet-unit-tests , cardano-sl-core , cardano-sl-core-test , cardano-sl-crypto + , cardano-sl-crypto-test , cardano-sl-db , cardano-sl-networking , cardano-sl-util diff --git a/wallet-new/server/Main.hs b/wallet-new/server/Main.hs index 2a311aa7fcf..b69f9bacfbb 100644 --- a/wallet-new/server/Main.hs +++ b/wallet-new/server/Main.hs @@ -16,9 +16,8 @@ import Pos.Chain.Ssc (SscParams) import Pos.Chain.Txp (TxpConfiguration) import qualified Pos.Client.CLI as CLI import Pos.Context (ncUserSecret) -import Pos.Core (Config (..), epochSlots) +import Pos.Core as Core (Config (..), configBlkSecurityParam) import Pos.Core.Genesis (GeneratedSecrets) -import Pos.Crypto (ProtocolMagic) import Pos.DB.DB (initNodeDBs) import Pos.DB.Txp (txpGlobalSettings) import Pos.Infra.Diffusion.Types (Diffusion) @@ -66,22 +65,25 @@ defaultLoggerName = "node" -- | The "workhorse" responsible for starting a Cardano edge node plus a number of extra plugins. actionWithWallet :: (HasConfigurations, HasCompileInfo) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> SscParams -> NodeParams -> NtpConfiguration -> WalletBackendParams -> IO () -actionWithWallet pm txpConfig sscParams nodeParams ntpConfig wArgs@WalletBackendParams {..} = +actionWithWallet coreConfig txpConfig sscParams nodeParams ntpConfig wArgs@WalletBackendParams {..} = bracketWalletWebDB (walletDbPath walletDbOptions) (walletRebuildDb walletDbOptions) $ \db -> bracketWalletWS $ \conn -> - bracketNodeResources nodeParams sscParams - (txpGlobalSettings pm txpConfig) - (initNodeDBs pm epochSlots) $ \nr@NodeResources {..} -> do + bracketNodeResources + (configBlkSecurityParam coreConfig) + nodeParams + sscParams + (txpGlobalSettings (configProtocolMagic coreConfig) txpConfig) + (initNodeDBs coreConfig) $ \nr@NodeResources {..} -> do syncQueue <- liftIO newTQueueIO ntpStatus <- withNtpClient (ntpClientSettings ntpConfig) - runWRealMode pm txpConfig db conn syncQueue nr (mainAction ntpStatus nr) + runWRealMode coreConfig txpConfig db conn syncQueue nr (mainAction ntpStatus nr) where mainAction ntpStatus = runNodeWithInit ntpStatus $ do when (walletFlushDb walletDbOptions) $ do @@ -96,7 +98,7 @@ actionWithWallet pm txpConfig sscParams nodeParams ntpConfig wArgs@WalletBackend runNodeWithInit ntpStatus init' nr diffusion = do _ <- init' - runNode pm txpConfig nr (plugins ntpStatus) diffusion + runNode coreConfig txpConfig nr (plugins ntpStatus) diffusion syncWallets :: WalletWebMode () syncWallets = do @@ -107,40 +109,45 @@ actionWithWallet pm txpConfig sscParams nodeParams ntpConfig wArgs@WalletBackend plugins :: TVar NtpStatus -> Plugins.Plugin WalletWebMode plugins ntpStatus = mconcat [ Plugins.conversation wArgs - , Plugins.legacyWalletBackend pm txpConfig wArgs ntpStatus + , Plugins.legacyWalletBackend coreConfig txpConfig wArgs ntpStatus , Plugins.walletDocumentation wArgs , Plugins.acidCleanupWorker wArgs - , Plugins.syncWalletWorker - , Plugins.resubmitterPlugin pm txpConfig + , Plugins.syncWalletWorker (configBlkSecurityParam coreConfig) + , Plugins.resubmitterPlugin coreConfig txpConfig , Plugins.notifierPlugin ] actionWithNewWallet :: (HasConfigurations, HasCompileInfo) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> SscParams -> NodeParams -> NtpConfiguration -> NewWalletBackendParams -> IO () -actionWithNewWallet pm txpConfig sscParams nodeParams ntpConfig params = +actionWithNewWallet coreConfig txpConfig sscParams nodeParams ntpConfig params = bracketNodeResources + (configBlkSecurityParam coreConfig) nodeParams sscParams (txpGlobalSettings pm txpConfig) - (initNodeDBs pm epochSlots) $ \nr -> do + (initNodeDBs coreConfig) $ \nr -> do ntpStatus <- withNtpClient (ntpClientSettings ntpConfig) userSecret <- readTVarIO (ncUserSecret $ nrContext nr) - let nodeState = NodeStateAdaptor.newNodeStateAdaptor nr ntpStatus + let nodeState = NodeStateAdaptor.newNodeStateAdaptor + (configProtocolConstants coreConfig) + nr + ntpStatus liftIO $ Keystore.bracketLegacyKeystore userSecret $ \keystore -> do WalletLayer.Kernel.bracketPassiveWallet logMessage' keystore nodeState $ \walletLayer passiveWallet -> do Kernel.init passiveWallet - Kernel.Mode.runWalletMode pm + Kernel.Mode.runWalletMode coreConfig txpConfig nr walletLayer (mainAction (walletLayer, passiveWallet) nr) where + pm = configProtocolMagic coreConfig mainAction :: (PassiveWalletLayer IO, PassiveWallet) -> NodeResources ext @@ -151,7 +158,7 @@ actionWithNewWallet pm txpConfig sscParams nodeParams ntpConfig params = :: (PassiveWalletLayer IO, PassiveWallet) -> NodeResources ext -> (Diffusion Kernel.Mode.WalletMode -> Kernel.Mode.WalletMode ()) - runNodeWithInit w nr = runNode pm txpConfig nr (plugins w) + runNodeWithInit w nr = runNode coreConfig txpConfig nr (plugins w) -- TODO: Don't know if we need any of the other plugins that are used -- in the legacy wallet (see 'actionWithWallet'). @@ -180,14 +187,14 @@ startEdgeNode wso = ntpConfig case wsoWalletBackendParams wso of WalletLegacy legacyParams -> actionWithWallet - (configProtocolMagic coreConfig) + coreConfig txpConfig sscParams nodeParams ntpConfig legacyParams WalletNew newParams -> actionWithNewWallet - (configProtocolMagic coreConfig) + coreConfig txpConfig sscParams nodeParams diff --git a/wallet-new/src/Cardano/Wallet/API/V0/Handlers.hs b/wallet-new/src/Cardano/Wallet/API/V0/Handlers.hs index a5b8dd8f005..f0a5472cbc6 100644 --- a/wallet-new/src/Cardano/Wallet/API/V0/Handlers.hs +++ b/wallet-new/src/Cardano/Wallet/API/V0/Handlers.hs @@ -4,7 +4,7 @@ module Cardano.Wallet.API.V0.Handlers where import qualified Cardano.Wallet.API.V0 as V0 import Ntp.Client (NtpStatus) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Crypto (ProtocolMagic) +import Pos.Core as Core (Config) import Pos.Infra.Diffusion.Types (Diffusion (sendTx)) import Pos.Util.CompileInfo (HasCompileInfo) import Pos.Wallet.Web.Mode (MonadFullWalletWebMode) @@ -20,12 +20,12 @@ import Universum -- a Servant's @Handler@, I can give you back a "plain old" Server. handlers :: ( MonadFullWalletWebMode ctx m, HasCompileInfo ) => (forall a. m a -> Handler a) - -> ProtocolMagic + -> Core.Config -> TxpConfiguration -> Diffusion m -> TVar NtpStatus -> Server V0.API -handlers naturalTransformation pm txpConfig diffusion ntpStatus = hoistServer +handlers naturalTransformation coreConfig txpConfig diffusion ntpStatus = hoistServer (Proxy @V0.API) naturalTransformation - (V0.servantHandlers pm txpConfig ntpStatus (sendTx diffusion)) + (V0.servantHandlers coreConfig txpConfig 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 c7294299c7b..980d791f7e3 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers.hs @@ -11,7 +11,7 @@ import Universum import Ntp.Client (NtpStatus) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Crypto (ProtocolMagic) +import Pos.Core as Core (Config, configBlkSecurityParam) import Pos.Infra.Diffusion.Types (Diffusion (sendTx)) import qualified Cardano.Wallet.API.V1 as V1 @@ -41,16 +41,16 @@ handlers :: ( HasConfigurations , HasCompileInfo ) => (forall a. MonadV1 a -> Handler a) - -> ProtocolMagic + -> Core.Config -> TxpConfiguration -> Diffusion MonadV1 -> TVar NtpStatus -> Server V1.API -handlers naturalTransformation pm txpConfig diffusion ntpStatus = +handlers naturalTransformation coreConfig txpConfig diffusion ntpStatus = hoist' (Proxy @Addresses.API) Addresses.handlers - :<|> hoist' (Proxy @Wallets.API) Wallets.handlers + :<|> hoist' (Proxy @Wallets.API) (Wallets.handlers $ configBlkSecurityParam coreConfig) :<|> hoist' (Proxy @Accounts.API) Accounts.handlers - :<|> hoist' (Proxy @Transactions.API) (Transactions.handlers pm txpConfig sendTx') + :<|> hoist' (Proxy @Transactions.API) (Transactions.handlers coreConfig txpConfig sendTx') :<|> hoist' (Proxy @Settings.API) Settings.handlers :<|> hoist' (Proxy @Info.API) (Info.handlers diffusion ntpStatus) where 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 5526ec30df5..647088af388 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Transactions.hs @@ -11,7 +11,6 @@ import Pos.Client.Txp.Util (defaultInputSelectionPolicy) import qualified Pos.Client.Txp.Util as V0 import qualified Pos.Core as Core import Pos.Core.Txp (TxAux) -import Pos.Crypto (ProtocolMagic) import qualified Pos.Util.Servant as V0 import qualified Pos.Wallet.WalletMode as V0 import qualified Pos.Wallet.Web.ClientTypes.Types as V0 @@ -60,25 +59,25 @@ convertTxError err = case err of handlers :: HasConfigurations - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> MonadV1 Bool) -> ServerT Transactions.API MonadV1 -handlers pm txpConfig submitTx = - newTransaction pm txpConfig submitTx +handlers coreConfig txpConfig submitTx = + newTransaction coreConfig txpConfig submitTx :<|> allTransactions - :<|> estimateFees pm - :<|> redeemAda pm txpConfig submitTx + :<|> estimateFees coreConfig + :<|> redeemAda coreConfig txpConfig submitTx newTransaction :: forall ctx m . (V0.MonadWalletTxFull ctx m) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> m Bool) -> Payment -> m (WalletResponse Transaction) -newTransaction pm txpConfig submitTx Payment {..} = do +newTransaction coreConfig txpConfig submitTx Payment {..} = do ws <- V0.askWalletSnapshot sourceWallet <- migrate (psWalletId pmtSource) @@ -101,7 +100,7 @@ newTransaction pm txpConfig 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 txpConfig submitTx spendingPw batchPayment + cTx <- V0.newPaymentBatch coreConfig txpConfig submitTx spendingPw batchPayment single <$> migrate cTx @@ -146,17 +145,17 @@ allTransactions mwalletId mAccIdx mAddr requestParams fops sops = estimateFees :: (MonadThrow m, V0.MonadFees ctx m) - => ProtocolMagic + => Core.Config -> Payment -> m (WalletResponse EstimatedFees) -estimateFees pm Payment{..} = do +estimateFees coreConfig 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 coreConfig pendingAddrs utxo outputs) case efee of Right fee -> single <$> migrate fee @@ -165,12 +164,12 @@ estimateFees pm Payment{..} = do redeemAda :: HasConfigurations - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> MonadV1 Bool) -> Redemption -> MonadV1 (WalletResponse Transaction) -redeemAda pm txpConfig submitTx r = do +redeemAda coreConfig txpConfig submitTx r = do let ShieldedRedemptionCode seed = redemptionRedemptionCode r V1 spendingPassword = redemptionSpendingPassword r walletId = redemptionWalletId r @@ -185,10 +184,10 @@ redeemAda pm txpConfig submitTx r = do , V0.pvSeed = seed , V0.pvBackupPhrase = phrase } - V0.redeemAdaPaperVend pm txpConfig submitTx spendingPassword cpaperRedeem + V0.redeemAdaPaperVend coreConfig txpConfig submitTx spendingPassword cpaperRedeem Nothing -> do let cwalletRedeem = V0.CWalletRedeem { V0.crWalletId = caccountId , V0.crSeed = seed } - V0.redeemAda pm txpConfig submitTx spendingPassword cwalletRedeem + V0.redeemAda coreConfig txpConfig submitTx spendingPassword cwalletRedeem 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 07e17339681..58690b2eea2 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs @@ -36,8 +36,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 @@ -55,14 +55,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 @@ -74,16 +74,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.newWalletNoThrow newWalletHandler RestoreWallet = V0.restoreWalletFromSeedNoThrow diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs b/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs index a41e038b950..be88cece173 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs @@ -14,7 +14,7 @@ import Universum import Pos.Chain.Block import Pos.Chain.Txp import Pos.Context -import Pos.Core +import Pos.Core as Core (Config, HasConfiguration) import Pos.Core.Chrono import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Core.Reporting (HasMisbehaviorMetrics (..)) @@ -81,22 +81,22 @@ 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 -------------------------------------------------------------------------------} runWalletMode :: forall a. (HasConfigurations, HasCompileInfo) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> NodeResources () -> PassiveWalletLayer IO -> (Diffusion WalletMode -> WalletMode a) -> IO a -runWalletMode pm txpConfig nr wallet action = - runRealMode pm txpConfig nr $ \diffusion -> +runWalletMode coreConfig txpConfig nr wallet action = + runRealMode coreConfig txpConfig nr $ \diffusion -> walletModeToRealMode wallet (action (hoistDiffusion realModeToWalletMode (walletModeToRealMode wallet) diffusion)) walletModeToRealMode :: forall a. PassiveWalletLayer IO -> WalletMode a -> RealMode () a @@ -177,9 +177,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/Kernel/NodeStateAdaptor.hs b/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs index ad2cb34ae2b..8e4d79435af 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs @@ -64,9 +64,8 @@ import Pos.Chain.Update (ConfirmedProposalState, import qualified Pos.Chain.Update as Upd import Pos.Context (NodeContext (..)) import Pos.Core (ProtocolConstants (pcK), SlotCount, Timestamp, - genesisBlockVersionData, pcEpochSlots) -import Pos.Core.Configuration (HasConfiguration, genesisHash, - protocolConstants) + configEpochSlots, genesisBlockVersionData, pcEpochSlots) +import Pos.Core.Configuration (HasConfiguration, genesisHash) import Pos.Core.Slotting (EpochIndex (..), HasSlottingVar (..), LocalSlotIndex (..), MonadSlots (..), SlotId (..)) import Pos.Core.Txp (TxIn, TxOutAux) @@ -327,7 +326,7 @@ instance ( NodeConstraints dbGetSerUndo = DB.dbGetSerUndoRealDefault dbGetSerBlund = DB.dbGetSerBlundRealDefault -instance (NodeConstraints, MonadIO m) => MonadSlots Res (WithNodeState m) where +instance MonadIO m => MonadSlots Res (WithNodeState m) where getCurrentSlot = S.getCurrentSlotSimple getCurrentSlotBlocking = S.getCurrentSlotBlockingSimple getCurrentSlotInaccurate = S.getCurrentSlotInaccurateSimple @@ -342,17 +341,18 @@ instance (NodeConstraints, MonadIO m) => MonadSlots Res (WithNodeState m) where -- NOTE: This captures the node constraints in the closure so that the adaptor -- can be used in a place where these constraints is not available. newNodeStateAdaptor :: forall m ext. (NodeConstraints, MonadIO m, MonadMask m) - => NodeResources ext + => ProtocolConstants + -> NodeResources ext -> TVar NtpStatus -> NodeStateAdaptor m -newNodeStateAdaptor nr ntpStatus = Adaptor { - withNodeState = run +newNodeStateAdaptor pc nr ntpStatus = Adaptor + { withNodeState = run , getTipSlotId = run $ \_lock -> defaultGetTipSlotId , getMaxTxSize = run $ \_lock -> defaultGetMaxTxSize , getSlotStart = \slotId -> run $ \_lock -> defaultGetSlotStart slotId , getNextEpochSlotDuration = run $ \_lock -> defaultGetNextEpochSlotDuration - , getSecurityParameter = return $ pcK' protocolConstants - , getSlotCount = return $ pcEpochSlots protocolConstants + , getSecurityParameter = return $ pcK' pc + , getSlotCount = return $ pcEpochSlots pc , curSoftwareVersion = return $ Upd.curSoftwareVersion , compileInfo = return $ Util.compileInfo , getNtpDrift = defaultGetNtpDrift ntpStatus @@ -504,7 +504,7 @@ instance Exception NodeStateUnavailable mockNodeState :: (HasCallStack, MonadThrow m) => MockNodeStateParams -> NodeStateAdaptor m mockNodeState MockNodeStateParams{..} = - withDefConfiguration $ \_pm -> + withDefConfiguration $ \coreConfig -> withDefUpdateConfiguration $ Adaptor { withNodeState = \_ -> throwM $ NodeStateUnavailable callStack @@ -513,7 +513,7 @@ mockNodeState MockNodeStateParams{..} = , getNextEpochSlotDuration = return mockNodeStateNextEpochSlotDuration , getSlotStart = return . mockNodeStateSlotStart , getMaxTxSize = return $ bvdMaxTxSize genesisBlockVersionData - , getSlotCount = return $ pcEpochSlots protocolConstants + , getSlotCount = return $ configEpochSlots coreConfig , curSoftwareVersion = return $ Upd.curSoftwareVersion , compileInfo = return $ Util.compileInfo , getNtpDrift = return . mockNodeStateNtpDrift diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Restore.hs b/wallet-new/src/Cardano/Wallet/Kernel/Restore.hs index 70b0ed8ece2..f33c69bb206 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Restore.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Restore.hs @@ -49,8 +49,8 @@ import Cardano.Wallet.Kernel.Wallets (createWalletHdRnd) import Pos.Chain.Block (Block, Blund, HeaderHash, MainBlock, Undo, headerHash, mainBlockSlot) import Pos.Chain.Txp (GenesisUtxo (..), Utxo, genesisUtxo) -import Pos.Core (BlockCount (..), Coin, SlotId, flattenSlotIdExplicit, - mkCoin, unsafeIntegerToCoin) +import Pos.Core (BlockCount (..), Coin, SlotId, flattenSlotId, mkCoin, + unsafeIntegerToCoin) import Pos.Core.Txp (TxIn (..), TxOut (..), TxOutAux (..)) import Pos.Crypto (EncryptedSecretKey) import Pos.DB.Block (getFirstGenesisBlockHash, getUndo, @@ -93,7 +93,7 @@ restoreWallet pw spendingPass name assurance esk prefilter = do slotCount <- getSlotCount (pw ^. walletNode) let restoreInfo = WalletRestorationInfo { _wriCurrentSlot = 0 - , _wriTargetSlot = flattenSlotIdExplicit slotCount tgtSlot + , _wriTargetSlot = flattenSlotId slotCount tgtSlot , _wriThroughput = MeasuredIn 0 , _wriCancel = return () } @@ -235,7 +235,7 @@ restoreWalletHistoryAsync wallet rootId target tgtSlot prefilter = do -- Update our progress slotCount <- getSlotCount (wallet ^. walletNode) - let flat = flattenSlotIdExplicit slotCount + let flat = flattenSlotId slotCount blockPerSec = MeasuredIn . BlockCount . perSecond <$> rate throughputUpdate = maybe identity (set wriThroughput) blockPerSec slotId = mb ^. mainBlockSlot diff --git a/wallet-new/src/Cardano/Wallet/LegacyServer.hs b/wallet-new/src/Cardano/Wallet/LegacyServer.hs index 9325e483613..01fa158d863 100644 --- a/wallet-new/src/Cardano/Wallet/LegacyServer.hs +++ b/wallet-new/src/Cardano/Wallet/LegacyServer.hs @@ -13,7 +13,7 @@ import Cardano.Wallet.Server.CLI (RunMode (..)) import Ntp.Client (NtpStatus) import Pos.Chain.Txp (TxpConfiguration) import Pos.Chain.Update (curSoftwareVersion) -import Pos.Crypto (ProtocolMagic) +import Pos.Core as Core (Config) import Pos.Infra.Diffusion.Types (Diffusion (..)) import Pos.Util.CompileInfo (compileInfo) import Pos.Wallet.Web.Mode (WalletWebMode) @@ -29,20 +29,20 @@ import qualified Cardano.Wallet.API.V1.Swagger as Swagger -- with Servant. walletServer :: (HasConfigurations, HasCompileInfo) => (forall a. WalletWebMode a -> Handler a) - -> ProtocolMagic + -> Core.Config -> TxpConfiguration -> Diffusion WalletWebMode -> TVar NtpStatus -> RunMode -> Server WalletAPI -walletServer natV0 pm txpConfig diffusion ntpStatus runMode = +walletServer natV0 coreConfig txpConfig diffusion ntpStatus runMode = v0Handler :<|> v0Handler :<|> v1Handler :<|> internalHandler where - v0Handler = V0.handlers natV0 pm txpConfig diffusion ntpStatus - v1Handler = V1.handlers natV0 pm txpConfig diffusion ntpStatus + v0Handler = V0.handlers natV0 coreConfig txpConfig diffusion ntpStatus + v1Handler = V1.handlers natV0 coreConfig txpConfig diffusion ntpStatus internalHandler = Internal.handlers natV0 runMode diff --git a/wallet-new/src/Cardano/Wallet/Server/Plugins.hs b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs index 5c2051c95c0..8cb5388362a 100644 --- a/wallet-new/src/Cardano/Wallet/Server/Plugins.hs +++ b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs @@ -55,6 +55,7 @@ import Pos.Wallet.Web.Sockets (getWalletWebSockets, import qualified Servant import Pos.Context (HasNodeContext) +import Pos.Core as Core (BlockCount, Config) import Pos.Crypto (ProtocolMagic) import Pos.Util (lensOf) import Pos.Util.Wlog (logInfo, modifyLoggerName, usingLoggerName) @@ -117,12 +118,12 @@ walletDocumentation WalletBackendParams {..} = pure $ \_ -> -- | A @Plugin@ to start the wallet backend API. legacyWalletBackend :: (HasConfigurations, HasCompileInfo) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> WalletBackendParams -> TVar NtpStatus -> Plugin WalletWebMode -legacyWalletBackend pm txpConfig WalletBackendParams {..} ntpStatus = pure $ \diffusion -> do +legacyWalletBackend coreConfig txpConfig WalletBackendParams {..} ntpStatus = pure $ \diffusion -> do modifyLoggerName (const "legacyServantBackend") $ do logInfo $ sformat ("Production mode for API: "%build) walletProductionApi @@ -153,7 +154,7 @@ legacyWalletBackend pm txpConfig WalletBackendParams {..} ntpStatus = pure $ \di $ Servant.serve API.walletAPI $ LegacyServer.walletServer (V0.convertHandler ctx) - pm + coreConfig txpConfig diffusion ntpStatus @@ -235,21 +236,21 @@ walletBackend protocolMagic (NewWalletBackendParams WalletBackendParams{..}) (pa -- | A @Plugin@ to resubmit pending transactions. resubmitterPlugin :: HasConfigurations - => ProtocolMagic + => Core.Config -> TxpConfiguration -> Plugin WalletWebMode -resubmitterPlugin pm txpConfig = [\diffusion -> askWalletDB >>= \db -> - startPendingTxsResubmitter pm txpConfig db (sendTx diffusion)] +resubmitterPlugin coreConfig txpConfig = [\diffusion -> askWalletDB >>= \db -> + startPendingTxsResubmitter coreConfig txpConfig 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/src/Cardano/Wallet/WalletLayer/Kernel/Transactions.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Transactions.hs index e4764fc8557..e95df0f50bb 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Transactions.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Transactions.hs @@ -9,7 +9,7 @@ import Control.Monad.Except import GHC.TypeLits (symbolVal) import Pos.Core (Address, Coin, SlotCount, SlotId, Timestamp, - decodeTextAddress, flattenSlotIdExplicit, getBlockCount) + decodeTextAddress, flattenSlotId, getBlockCount) import Pos.Core.Txp (TxId) import Cardano.Wallet.API.Indices @@ -150,8 +150,8 @@ buildDynamicTxMeta assuranceLevel slotCount mSlot currentSlot isPending = case i case mSlot of Nothing -> (V1.WontApply, 0) Just confirmedIn -> - let currentSlot' = flattenSlotIdExplicit slotCount currentSlot - confirmedIn' = flattenSlotIdExplicit slotCount confirmedIn + let currentSlot' = flattenSlotId slotCount currentSlot + confirmedIn' = flattenSlotId slotCount confirmedIn confirmations = currentSlot' - confirmedIn' in case (confirmations < getBlockCount (HD.assuredBlockDepth assuranceLevel)) of True -> (V1.InNewestBlocks, confirmations) diff --git a/wallet-new/test/MarshallingSpec.hs b/wallet-new/test/MarshallingSpec.hs index 7886867d64d..512d66028dd 100644 --- a/wallet-new/test/MarshallingSpec.hs +++ b/wallet-new/test/MarshallingSpec.hs @@ -52,7 +52,6 @@ import qualified Cardano.Wallet.Util as Util spec :: HasCallStack => Spec spec = parallel $ describe "Marshalling & Unmarshalling" $ do parallel $ describe "Roundtrips" $ do - pc <- runIO $ generate arbitrary aesonRoundtripProp @Account Proxy aesonRoundtripProp @AssuranceLevel Proxy aesonRoundtripProp @BackupPhrase Proxy @@ -157,14 +156,12 @@ spec = parallel $ describe "Marshalling & Unmarshalling" $ do safeCopyRoundTrip @(InDb (Core.AddressHash Core.Address')) safeCopyRoundTrip @(InDb (Core.Attributes Core.AddrAttributes)) safeCopyRoundTrip @(InDb (Core.AddrType)) - describe "Needing protocol constants ... " $ do - Core.withProtocolConstants pc $ do - safeCopyRoundTrip @(InDb Core.SlotId) - safeCopyRoundTrip @(InDb Core.LocalSlotIndex) - safeCopyRoundTrip @(InDb Core.BlockHeader) - safeCopyRoundTrip @(InDb Core.MainBlockHeader) - safeCopyRoundTrip @(InDb Core.MainConsensusData) - safeCopyRoundTrip @(InDb Core.BlockSignature) + safeCopyRoundTrip @(InDb Core.SlotId) + safeCopyRoundTrip @(InDb Core.LocalSlotIndex) + safeCopyRoundTrip @(InDb Core.BlockHeader) + safeCopyRoundTrip @(InDb Core.MainBlockHeader) + safeCopyRoundTrip @(InDb Core.MainConsensusData) + safeCopyRoundTrip @(InDb Core.BlockSignature) -- Other roundtrips generalRoundtripProp "UTC time" Util.showApiUtcTime Util.parseApiUtcTime diff --git a/wallet-new/test/WalletHandlersSpec.hs b/wallet-new/test/WalletHandlersSpec.hs index 1b8abb41a76..b2c90233086 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,19 @@ 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 (Core.BlockCount k) = dummyK let progress = newSyncProgress (totalBlocks - k) totalBlocks - V1.isNodeSufficientlySynced progress `shouldBe` True + V1.isNodeSufficientlySynced dummyK progress `shouldBe` True it "should return False if we are more than k blocks behind" $ do - let (Core.BlockCount k) = Core.blkSecurityParam + let (Core.BlockCount k) = dummyK let progress = newSyncProgress (totalBlocks - k - 1) totalBlocks - V1.isNodeSufficientlySynced progress `shouldBe` False + V1.isNodeSufficientlySynced dummyK progress `shouldBe` False it "should return False if we cannot fetch the blockchain height" $ do - let (Core.BlockCount k) = Core.blkSecurityParam + let (Core.BlockCount k) = dummyK let progress = newSyncProgress (totalBlocks - k - 1) totalBlocks - V1.isNodeSufficientlySynced (progress { V0._spNetworkCD = Nothing }) `shouldBe` False + V1.isNodeSufficientlySynced dummyK (progress { V0._spNetworkCD = Nothing }) + `shouldBe` False diff --git a/wallet-new/test/unit/UTxO/Context.hs b/wallet-new/test/unit/UTxO/Context.hs index 70e3a90c1e6..b7e2a274ec1 100644 --- a/wallet-new/test/unit/UTxO/Context.hs +++ b/wallet-new/test/unit/UTxO/Context.hs @@ -100,18 +100,18 @@ initCardanoContext coreConfig = CardanoContext , ccUtxo = ccUtxo , ccSecrets = fromMaybe (error "initCardanoContext: no secrets") $ configGeneratedSecrets coreConfig - , ccMagic = configProtocolMagic coreConfig + , ccMagic = ccMagic , ccInitLeaders = ccLeaders , ccBalances = utxoToAddressCoinPairs ccUtxo , ccHash0 = (blockHeaderHash . BlockHeaderGenesis . _gbHeader) ccBlock0 - , ccEpochSlots = epochSlots + , ccEpochSlots = ccEpochSlots } where - ccLeaders = genesisLeaders epochSlots - ccBlock0 = genesisBlock0 (configProtocolMagic coreConfig) - (GenesisHash genesisHash) - ccLeaders - ccUtxo = unGenesisUtxo genesisUtxo + ccEpochSlots = configEpochSlots coreConfig + ccLeaders = genesisLeaders ccEpochSlots + ccMagic = configProtocolMagic coreConfig + ccBlock0 = genesisBlock0 ccMagic (GenesisHash genesisHash) ccLeaders + ccUtxo = unGenesisUtxo genesisUtxo {------------------------------------------------------------------------------- More explicit representation of the various actors in the genesis block diff --git a/wallet-new/test/unit/UTxO/Interpreter.hs b/wallet-new/test/unit/UTxO/Interpreter.hs index dc4f66e2ce8..3a281963277 100644 --- a/wallet-new/test/unit/UTxO/Interpreter.hs +++ b/wallet-new/test/unit/UTxO/Interpreter.hs @@ -75,6 +75,8 @@ import UTxO.Crypto import qualified UTxO.DSL as DSL import UTxO.Translate +import Test.Pos.Core.Dummy (dummyConfig, dummyEpochSlots, dummyK) + {------------------------------------------------------------------------------- Errors that may occur during interpretation -------------------------------------------------------------------------------} @@ -351,9 +353,8 @@ mkCheckpoint :: Monad m -> RawResolvedBlock -- ^ The block just created -> TranslateT IntException m IntCheckpoint mkCheckpoint prev raw@(UnsafeRawResolvedBlock block _inputs _ ctxt) = do - pc <- asks constants gs <- asks weights - let isCrucial = give pc $ slot == crucialSlot (siEpoch slot) + let isCrucial = slot == crucialSlot dummyK (siEpoch slot) newStakes <- updateStakes gs (fromRawResolvedBlock raw) (icStakes prev) return IntCheckpoint { icSlotId = slot @@ -640,7 +641,6 @@ instance DSL.Hash h Addr => Interpret h (DSL.Block h Addr) where int (OldestFirst txs) = do (txs', resolvedTxInputs) <- unpack <$> mapM int txs pushCheckpoint $ \prev slot -> do - pc <- asks constants block <- mkBlock (icEpochLeaders prev) (icBlockHeader prev) @@ -654,17 +654,17 @@ instance DSL.Hash h Addr => Interpret h (DSL.Block h Addr) where } let raw = mkRawResolvedBlock block resolvedTxInputs currentTime ctxt checkpoint <- mkCheckpoint prev raw - if isEpochBoundary pc slot + if isEpochBoundary slot then second (\ebb -> (raw, Just ebb)) <$> createEpochBoundary checkpoint else return (checkpoint, (raw, Nothing)) where unpack :: [RawResolvedTx] -> ([TxAux], [ResolvedTxInputs]) unpack = unzip . map (rawResolvedTx &&& rawResolvedTxInputs) - isEpochBoundary :: ProtocolConstants -> SlotId -> Bool - isEpochBoundary pc slot = siSlot slot == localSlotIndexMaxBound pc + isEpochBoundary :: SlotId -> Bool + isEpochBoundary slot = siSlot slot == localSlotIndexMaxBound dummyEpochSlots - mkBlock :: (HasConfiguration, HasUpdateConfiguration) + mkBlock :: HasUpdateConfiguration => SlotLeaders -> BlockHeader -> SlotId @@ -680,9 +680,8 @@ instance DSL.Hash h Addr => Interpret h (DSL.Block h Addr) where -- figure out who needs to sign the block BlockSignInfo{..} <- asks $ blockSignInfoForSlot leaders slotId - pm <- asks magic createMainBlockPure - pm + dummyConfig blockSizeLimit prev (Just (bsiPSK, bsiLeader)) @@ -690,7 +689,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 2c4c4615937..84e8db909e6 100644 --- a/wallet-new/test/unit/UTxO/Translate.hs +++ b/wallet-new/test/unit/UTxO/Translate.hs @@ -33,7 +33,6 @@ import Pos.Chain.Txp import Pos.Chain.Update import Pos.Core import Pos.Core.Chrono -import Pos.Crypto (ProtocolMagic) import Pos.DB.Class (MonadGState (..)) import Util.Validated @@ -41,6 +40,8 @@ import UTxO.Context import UTxO.Verify (Verify) import qualified UTxO.Verify as Verify +import Test.Pos.Core.Dummy (dummyEpochSlots) + {------------------------------------------------------------------------------- Testing infrastructure from cardano-sl-core @@ -170,7 +171,7 @@ translateFirstSlot = SlotId 0 localSlotIndexMinBound -- TODO: Surely a function like this must already exist somewhere? translateNextSlot :: Monad m => SlotId -> TranslateT e m SlotId translateNextSlot (SlotId epoch lsi) = withConfig $ - return $ case addLocalSlotIndex 1 lsi of + return $ case addLocalSlotIndex dummyEpochSlots 1 lsi of Just lsi' -> SlotId epoch lsi' Nothing -> SlotId (epoch + 1) localSlotIndexMinBound @@ -216,32 +217,26 @@ verifyBlocksPrefix blocks = validatedFromExceptT . throwError $ VerifyBlocksError "No genesis epoch!" ESRValid genEpoch (OldestFirst succEpochs) -> do CardanoContext{..} <- asks tcCardano - verify $ validateGenEpoch ccMagic ccHash0 ccInitLeaders genEpoch >>= \genUndos -> do - epochUndos <- sequence $ validateSuccEpoch ccMagic <$> succEpochs + verify $ validateGenEpoch ccHash0 ccInitLeaders genEpoch >>= \genUndos -> do + epochUndos <- sequence $ validateSuccEpoch <$> succEpochs return $ foldl' (\a b -> a <> b) genUndos epochUndos where - validateGenEpoch :: ProtocolMagic - -> HeaderHash + validateGenEpoch :: HeaderHash -> SlotLeaders -> OldestFirst NE MainBlock - -> ( HasConfiguration - => Verify VerifyBlocksException (OldestFirst NE Undo)) - validateGenEpoch pm ccHash0 ccInitLeaders geb = do + -> Verify VerifyBlocksException (OldestFirst NE Undo) + validateGenEpoch ccHash0 ccInitLeaders geb = do Verify.verifyBlocksPrefix - pm ccHash0 Nothing ccInitLeaders (OldestFirst []) (Right <$> geb :: OldestFirst NE Block) - validateSuccEpoch :: ProtocolMagic - -> EpochBlocks NE - -> ( HasConfiguration - => Verify VerifyBlocksException (OldestFirst NE Undo)) - validateSuccEpoch pm (SuccEpochBlocks ebb emb) = do + validateSuccEpoch :: EpochBlocks NE + -> Verify VerifyBlocksException (OldestFirst NE Undo) + validateSuccEpoch (SuccEpochBlocks ebb emb) = do Verify.verifyBlocksPrefix - pm (ebb ^. headerHashG) Nothing (ebb ^. gbBody . gbLeaders) diff --git a/wallet-new/test/unit/UTxO/Verify.hs b/wallet-new/test/unit/UTxO/Verify.hs index c3d8d9556e7..9d18b1626db 100644 --- a/wallet-new/test/unit/UTxO/Verify.hs +++ b/wallet-new/test/unit/UTxO/Verify.hs @@ -36,6 +36,9 @@ import qualified Pos.Util.Modifier as MM import Pos.Util.Wlog import Serokell.Util.Verify +import Test.Pos.Core.Dummy (dummyConfig, dummyEpochSlots, dummyK) +import Test.Pos.Crypto.Dummy (dummyProtocolMagic) + {------------------------------------------------------------------------------- Verification environment -------------------------------------------------------------------------------} @@ -222,15 +225,13 @@ 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 - -> HeaderHash -- ^ Expected tip + :: HeaderHash -- ^ Expected tip -> Maybe SlotId -- ^ Current slot -> SlotLeaders -- ^ Slot leaders for this epoch -> LastBlkSlots -- ^ Last block slots -> OldestFirst NE Block -> Verify VerifyBlocksException (OldestFirst NE Undo) -verifyBlocksPrefix pm tip curSlot leaders lastSlots blocks = do +verifyBlocksPrefix tip curSlot leaders lastSlots blocks = do when (tip /= blocks ^. _Wrapped . _neHead . prevBlockL) $ throwError $ VerifyBlocksError "the first block isn't based on the tip" @@ -238,7 +239,7 @@ verifyBlocksPrefix pm tip curSlot leaders lastSlots blocks = do -- Verify block envelope slogUndos <- mapVerifyErrors VerifyBlocksError $ - slogVerifyBlocks pm curSlot leaders lastSlots blocks + slogVerifyBlocks curSlot leaders lastSlots blocks -- We skip SSC verification {- @@ -248,7 +249,7 @@ verifyBlocksPrefix pm tip curSlot leaders lastSlots blocks = do -- Verify transactions txUndo <- mapVerifyErrors (VerifyBlocksError . pretty) $ - tgsVerifyBlocks pm $ map toTxpBlock blocks + tgsVerifyBlocks $ map toTxpBlock blocks -- Skip delegation verification {- @@ -292,14 +293,12 @@ 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 - -> Maybe SlotId -- ^ Current slot + :: Maybe SlotId -- ^ Current slot -> SlotLeaders -- ^ Slot leaders for this epoch -> LastBlkSlots -- ^ Last block slots -> OldestFirst NE Block -> Verify Text (OldestFirst NE SlogUndo) -slogVerifyBlocks pm curSlot leaders lastSlots blocks = do +slogVerifyBlocks curSlot leaders lastSlots blocks = do adoptedBVD <- gsAdoptedBVData -- We take head here, because blocks are in oldest first order and @@ -312,12 +311,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 dummyConfig 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 @@ -327,7 +326,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 @@ -353,14 +352,14 @@ slogVerifyBlocks pm curSlot leaders lastSlots blocks = do -- * Does everything in a pure monad. -- I don't fully grasp the consequences of this. tgsVerifyBlocks - :: ProtocolMagic - -> OldestFirst NE TxpBlock + :: OldestFirst NE TxpBlock -> Verify ToilVerFailure (OldestFirst NE TxpUndo) -tgsVerifyBlocks pm newChain = do +tgsVerifyBlocks newChain = do bvd <- gsAdoptedBVData let epoch = NE.last (getOldestFirst newChain) ^. epochIndexL let verifyPure :: [TxAux] -> Verify ToilVerFailure TxpUndo - verifyPure = nat . verifyToil pm bvd mempty epoch dataMustBeKnown + verifyPure = nat . + verifyToil dummyProtocolMagic bvd mempty epoch dataMustBeKnown mapM (verifyPure . convertPayload) newChain where convertPayload :: TxpBlock -> [TxAux] diff --git a/wallet/Makefile b/wallet/Makefile index f117806d839..041426c14be 100644 --- a/wallet/Makefile +++ b/wallet/Makefile @@ -8,6 +8,6 @@ ghcid: ## Run ghcid with the wallet-new project ghcid-test: ## Have ghcid run the test suite for the wallet-new-specs on successful recompile ghcid \ --command "stack ghci cardano-sl-wallet:lib cardano-sl-wallet:test:cardano-wallet-test --ghci-options=-fobject-code" \ - --test "main" + --test "Main.main" .PHONY: ghcid ghcid-test help diff --git a/wallet/src/Pos/Wallet/Redirect.hs b/wallet/src/Pos/Wallet/Redirect.hs index 3c6aca431c9..bd1e43ec73d 100644 --- a/wallet/src/Pos/Wallet/Redirect.hs +++ b/wallet/src/Pos/Wallet/Redirect.hs @@ -30,10 +30,10 @@ import Pos.Chain.Block (BlockHeader, LastKnownHeaderTag, import Pos.Chain.Txp (ToilVerFailure, TxpConfiguration) import Pos.Chain.Update (ConfirmedProposalState) import qualified Pos.Context as PC -import Pos.Core (ChainDifficulty, HasConfiguration, Timestamp, - difficultyL, getCurrentTimestamp) +import Pos.Core as Core (ChainDifficulty, Config, HasConfiguration, + Timestamp, difficultyL, getCurrentTimestamp) import Pos.Core.Txp (Tx, TxAux (..), TxId, TxUndo) -import Pos.Crypto (ProtocolMagic, WithHash (..)) +import Pos.Crypto (WithHash (..)) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead) import qualified Pos.DB.GState.Common as GS @@ -134,13 +134,13 @@ txpProcessTxWebWallet , AccountMode ctx m , WS.WalletDbReader ctx m ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxId, TxAux) -> m (Either ToilVerFailure ()) -txpProcessTxWebWallet pm txpConfig tx@(txId, txAux) = do +txpProcessTxWebWallet coreConfig txpConfig tx@(txId, txAux) = do db <- WS.askWalletDB - txProcessTransaction pm txpConfig tx >>= traverse (const $ addTxToWallets db) + txProcessTransaction coreConfig txpConfig tx >>= traverse (const $ addTxToWallets db) where addTxToWallets :: WS.WalletDB -> m () addTxToWallets db = do @@ -165,7 +165,7 @@ txpNormalizeWebWallet :: ( TxpLocalWorkMode ctx m , MempoolExt m ~ () ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> m () txpNormalizeWebWallet = txNormalize diff --git a/wallet/src/Pos/Wallet/Web/Methods/Misc.hs b/wallet/src/Pos/Wallet/Web/Methods/Misc.hs index 4f97851386e..c0b1fe7b045 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Misc.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Misc.hs @@ -48,7 +48,8 @@ import Pos.Chain.Txp (TxId, TxIn, TxOut) import Pos.Chain.Update (HasUpdateConfiguration, curSoftwareVersion) import Pos.Client.KeyStorage (MonadKeys (..), deleteAllSecretKeys) import Pos.Configuration (HasNodeConfiguration) -import Pos.Core (HasConfiguration, SlotId) +import Pos.Core (HasConfiguration, ProtocolConstants, SlotId, + pcEpochSlots) import Pos.Core.Conc (async, delay) import Pos.Core.Update (SoftwareVersion (..)) import Pos.Crypto (hashHexF) @@ -215,10 +216,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 89406b590a4..3534ddf9265 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Payment.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Payment.hs @@ -30,12 +30,12 @@ import Pos.Client.Txp.Network (prepareMTx) import Pos.Client.Txp.Util (InputSelectionPolicy (..), computeTxFee, runTxCreator) import Pos.Configuration (walletTxCreationDisabled) -import Pos.Core (Address, Coin, HasConfiguration, getCurrentTimestamp) +import Pos.Core as Core (Address, Coin, Config (..), HasConfiguration, + getCurrentTimestamp) import Pos.Core.Conc (concurrently, delay) import Pos.Core.Txp (TxAux (..), TxOut (..), _txOutputs) -import Pos.Crypto (PassPhrase, ProtocolMagic, SafeSigner, - ShouldCheckPassphrase (..), checkPassMatches, hash, - withSafeSignerUnsafe) +import Pos.Crypto (PassPhrase, SafeSigner, ShouldCheckPassphrase (..), + checkPassMatches, hash, withSafeSignerUnsafe) import Pos.DB (MonadGState) import Pos.Util (eitherToThrow, maybeThrow) import Pos.Util.Servant (encodeCType) @@ -62,7 +62,7 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, getAccountAddrsOrThrow, newPayment :: MonadWalletTxFull ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> m Bool) -> PassPhrase @@ -71,14 +71,14 @@ newPayment -> Coin -> InputSelectionPolicy -> m CTx -newPayment pm txpConfig submitTx passphrase srcAccount dstAddress coin policy = +newPayment coreConfig txpConfig 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 -- `newPayment`s are done continuously. notFasterThan (6 :: Second) $ do sendMoney - pm + coreConfig txpConfig submitTx passphrase @@ -88,17 +88,17 @@ newPayment pm txpConfig submitTx passphrase srcAccount dstAddress coin policy = newPaymentBatch :: MonadWalletTxFull ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> m Bool) -> PassPhrase -> NewBatchPayment -> m CTx -newPaymentBatch pm txpConfig submitTx passphrase NewBatchPayment {..} = do +newPaymentBatch coreConfig txpConfig submitTx passphrase NewBatchPayment {..} = do src <- decodeCTypeOrFail npbFrom notFasterThan (6 :: Second) $ do sendMoney - pm + coreConfig txpConfig submitTx passphrase @@ -118,19 +118,19 @@ type MonadFees ctx m = getTxFee :: MonadFees ctx m - => ProtocolMagic + => Core.Config -> AccountId -> CId Addr -> Coin -> InputSelectionPolicy -> m CCoin -getTxFee pm srcAccount dstAccount coin policy = do +getTxFee coreConfig 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) + eitherToThrow =<< runTxCreator policy (computeTxFee coreConfig pendingAddrs utxo outputs) pure $ encodeCType fee data MoneySource @@ -177,7 +177,7 @@ getMoneySourceUtxo ws = sendMoney :: (MonadWalletTxFull ctx m) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> m Bool) -> PassPhrase @@ -185,7 +185,7 @@ sendMoney -> NonEmpty (CId Addr, Coin) -> InputSelectionPolicy -> m CTx -sendMoney pm txpConfig submitTx passphrase moneySource dstDistr policy = do +sendMoney coreConfig txpConfig submitTx passphrase moneySource dstDistr policy = do db <- askWalletDB ws <- getWalletSnapshot db when walletTxCreationDisabled $ @@ -229,7 +229,7 @@ sendMoney pm txpConfig 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 coreConfig getSigner pendingAddrs policy srcAddrs outputs (relatedAccount, passphrase) ts <- Just <$> getCurrentTimestamp let tx = taTx txAux @@ -238,9 +238,14 @@ sendMoney pm txpConfig 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 (configProtocolConstants coreConfig) + ws + srcWallet + txHash + txAux + th - th <$ submitAndSaveNewPtx pm txpConfig db submitTx ptx + th <$ submitAndSaveNewPtx coreConfig txpConfig 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 39652f50800..8ad482ee6ec 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs @@ -15,9 +15,9 @@ import qualified Serokell.Util.Base64 as B64 import Pos.Chain.Txp (TxpConfiguration) import Pos.Client.Txp.History (TxHistoryEntry (..)) import Pos.Client.Txp.Network (prepareRedemptionTx) -import Pos.Core (getCurrentTimestamp) +import Pos.Core as Core (Config (..), getCurrentTimestamp) import Pos.Core.Txp (TxAux (..), TxOut (..)) -import Pos.Crypto (PassPhrase, ProtocolMagic, aesDecrypt, hash, +import Pos.Crypto (PassPhrase, aesDecrypt, hash, redeemDeterministicKeyGen) import Pos.Util (maybeThrow) import Pos.Util.Mnemonic (mnemonicToAesKey) @@ -38,17 +38,17 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, getWalletAddrsDetector) redeemAda :: MonadWalletTxFull ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> m Bool) -> PassPhrase -> CWalletRedeem -> m CTx -redeemAda pm txpConfig submitTx passphrase CWalletRedeem {..} = do +redeemAda coreConfig txpConfig submitTx passphrase CWalletRedeem {..} = do seedBs <- maybe invalidBase64 pure -- NOTE: this is just safety measure $ rightToMaybe (B64.decode crSeed) <|> rightToMaybe (B64.decodeUrl crSeed) - redeemAdaInternal pm txpConfig submitTx passphrase crWalletId seedBs + redeemAdaInternal coreConfig txpConfig submitTx passphrase crWalletId seedBs where invalidBase64 = throwM . RequestError $ "Seed is invalid base64(url) string: " <> crSeed @@ -58,19 +58,19 @@ redeemAda pm txpConfig submitTx passphrase CWalletRedeem {..} = do -- * https://github.com/input-output-hk/postvend-app/blob/master/src/CertGen.hs#L160 redeemAdaPaperVend :: MonadWalletTxFull ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> m Bool) -> PassPhrase -> CPaperVendWalletRedeem -> m CTx -redeemAdaPaperVend pm txpConfig submitTx passphrase CPaperVendWalletRedeem {..} = do +redeemAdaPaperVend coreConfig txpConfig 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 txpConfig submitTx passphrase pvWalletId seedDecBs + redeemAdaInternal coreConfig txpConfig submitTx passphrase pvWalletId seedDecBs where invalidBase58 = throwM . RequestError $ "Seed is invalid base58 string: " <> pvSeed @@ -80,14 +80,14 @@ redeemAdaPaperVend pm txpConfig submitTx passphrase CPaperVendWalletRedeem {..} redeemAdaInternal :: MonadWalletTxFull ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> m Bool) -> PassPhrase -> CAccountId -> ByteString -> m CTx -redeemAdaInternal pm txpConfig submitTx passphrase cAccId seedBs = do +redeemAdaInternal coreConfig txpConfig submitTx passphrase cAccId seedBs = do (_, redeemSK) <- maybeThrow (RequestError "Seed is not 32-byte long") $ redeemDeterministicKeyGen seedBs accId <- decodeCTypeOrFail cAccId @@ -99,8 +99,10 @@ redeemAdaInternal pm txpConfig submitTx passphrase cAccId seedBs = do dstAddr <- decodeCTypeOrFail . cadId =<< L.newAddress RandomSeed passphrase accId ws <- getWalletSnapshot db th <- rewrapTxError "Cannot send redemption transaction" $ do - (txAux, redeemAddress, redeemBalance) <- - prepareRedemptionTx pm redeemSK dstAddr + (txAux, redeemAddress, redeemBalance) <- prepareRedemptionTx + (configProtocolMagic coreConfig) + redeemSK + dstAddr ts <- Just <$> getCurrentTimestamp let tx = taTx txAux @@ -108,9 +110,14 @@ redeemAdaInternal pm txpConfig 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 (configProtocolConstants coreConfig) + ws + dstWallet + txHash + txAux + th - th <$ submitAndSaveNewPtx pm txpConfig db submitTx ptx + th <$ submitAndSaveNewPtx coreConfig txpConfig 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 c0e0a655e52..90a93a58b97 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Txp.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Txp.hs @@ -23,10 +23,11 @@ import Pos.Client.KeyStorage (MonadKeys) import Pos.Client.Txp.Addresses (MonadAddresses (..)) import Pos.Client.Txp.Util (InputSelectionPolicy (..), PendingAddresses (..), isCheckedTxError) +import Pos.Core as Core (Config) import Pos.Core.Chrono (getNewestFirst, toNewestFirst) import Pos.Core.Common (Coin) import Pos.Core.Txp (Tx (..), TxAux (..), TxOut (..), TxOutAux (..)) -import Pos.Crypto (PassPhrase, ProtocolMagic, hash) +import Pos.Crypto (PassPhrase, hash) import Pos.Util.Servant (encodeCType) import Pos.Wallet.Web.ClientTypes (AccountId, Addr, CId) import Pos.Wallet.Web.Error (WalletError (..), rewrapToWalletError) @@ -74,14 +75,14 @@ coinDistrToOutputs distr = do -- by the time of resubmission. submitAndSaveNewPtx :: TxSubmissionMode ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> WalletDB -> (TxAux -> m Bool) -> PendingTx -> m () -submitAndSaveNewPtx pm txpConfig db submit = - submitAndSavePtx pm txpConfig db submit ptxFirstSubmissionHandler +submitAndSaveNewPtx coreConfig txpConfig db submit = + submitAndSavePtx coreConfig txpConfig 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 2d3aa1e8529..f19123dee60 100644 --- a/wallet/src/Pos/Wallet/Web/Mode.hs +++ b/wallet/src/Pos/Wallet/Web/Mode.hs @@ -239,9 +239,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 @@ -361,5 +359,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 509b0766fa2..abeb297c5f8 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Functions.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Functions.hs @@ -18,7 +18,7 @@ import Formatting (build, sformat, (%)) import Pos.Chain.Txp (ToilVerFailure (..)) 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.Util.Util (maybeThrow) @@ -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 a418ffcaee8..fc200dbe312 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Submission.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Submission.hs @@ -23,9 +23,9 @@ import Pos.Chain.Txp (TxpConfiguration) 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 as Core (Config (..), diffTimestamp, + getCurrentTimestamp) import Pos.Core.Txp (TxAux) -import Pos.Crypto (ProtocolMagic) import Pos.Infra.Util.LogSafe (buildSafe, logInfoSP, logWarningSP, secretOnlyF) import Pos.Util.Util (maybeThrow) @@ -109,14 +109,14 @@ type TxSubmissionMode ctx m = ( TxMode m ) -- but treats tx as future /pending/ transaction. submitAndSavePtx :: TxSubmissionMode ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> WalletDB -> (TxAux -> m Bool) -> PtxSubmissionHandlers m -> PendingTx -> m () -submitAndSavePtx pm txpConfig db submitTx PtxSubmissionHandlers{..} ptx@PendingTx{..} = do +submitAndSavePtx coreConfig txpConfig 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!" @@ -134,7 +134,7 @@ submitAndSavePtx pm txpConfig db submitTx PtxSubmissionHandlers{..} ptx@PendingT _ptxTxId | otherwise -> do addOnlyNewPendingTx db ptx - (saveTx pm txpConfig (_ptxTxId, _ptxTxAux) + (saveTx coreConfig txpConfig (_ptxTxId, _ptxTxAux) `catches` handlers) `onException` creationFailedHandler ack <- submitTx _ptxTxAux @@ -142,7 +142,12 @@ submitAndSavePtx pm txpConfig db submitTx PtxSubmissionHandlers{..} ptx@PendingT poolInfo <- badInitPtxCondition `maybeThrow` ptxPoolInfo _ptxCond _ <- usingPtxCoords (casPtxCondition db) ptx _ptxCond (PtxApplying poolInfo) - when ack $ ptxUpdateMeta db _ptxWallet _ptxTxId PtxMarkAcknowledged + when ack $ ptxUpdateMeta + (configProtocolConstants coreConfig) + 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 975a5ae8eec..fe10b54274d 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Util.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Util.hs @@ -19,7 +19,7 @@ import qualified Data.Set as Set import Pos.Chain.Txp (Tx (..), TxAux (..), TxOut (..), topsortTxs) 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 2cf47e87440..fc6f7f76458 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Worker.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Worker.hs @@ -20,12 +20,12 @@ import Pos.Client.Txp.Addresses (MonadAddresses) import Pos.Client.Txp.Network (TxMode) import Pos.Configuration (HasNodeConfiguration, pendingTxResubmitionPeriod, walletTxCreationDisabled) -import Pos.Core (ChainDifficulty (..), SlotId (..), difficultyL) +import Pos.Core as Core (ChainDifficulty (..), Config (..), + SlotId (..), configEpochSlots, difficultyL) import Pos.Core.Chrono (getOldestFirst) import Pos.Core.Conc (delay, forConcurrently) import Pos.Core.Configuration (HasConfiguration) import Pos.Core.Txp (TxAux) -import Pos.Crypto (ProtocolMagic) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead) import Pos.Infra.Recovery.Info (MonadRecoveryInfo) @@ -74,44 +74,52 @@ processPtxInNewestBlocks db PendingTx{..} = do ptxDiff + depth <= tipDiff resubmitTx :: MonadPendings ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> WalletDB -> (TxAux -> m Bool) -> PendingTx -> m () -resubmitTx pm txpConfig db submitTx ptx = +resubmitTx coreConfig txpConfig db submitTx ptx = handleAny (\_ -> pass) $ do logInfoSP $ \sl -> sformat ("Resubmitting tx "%secretOnlyF sl build) (_ptxTxId ptx) let submissionH = ptxResubmissionHandler db ptx - submitAndSavePtx pm txpConfig db submitTx submissionH ptx + submitAndSavePtx coreConfig txpConfig 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 (configProtocolConstants coreConfig) 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 + => Core.Config -> TxpConfiguration -> WalletDB -> (TxAux -> m Bool) -> [PendingTx] -> m () -resubmitPtxsDuringSlot pm txpConfig db submitTx ptxs = do +resubmitPtxsDuringSlot coreConfig txpConfig db submitTx ptxs = do interval <- evalSubmitDelay (length ptxs) void . forConcurrently (enumerate ptxs) $ \(i, ptx) -> do delay (interval * i) - resubmitTx pm txpConfig db submitTx ptx + resubmitTx coreConfig txpConfig db submitTx ptx where submitionEta = 5 :: Second evalSubmitDelay toResubmitNum = do @@ -122,14 +130,14 @@ resubmitPtxsDuringSlot pm txpConfig db submitTx ptxs = do processPtxsToResubmit :: MonadPendings ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> WalletDB -> (TxAux -> m Bool) -> SlotId -> [PendingTx] -> m () -processPtxsToResubmit pm txpConfig db submitTx _curSlot ptxs = do +processPtxsToResubmit coreConfig txpConfig db submitTx _curSlot ptxs = do ptxsPerSlotLimit <- evalPtxsPerSlotLimit let toResubmit = take (min 1 ptxsPerSlotLimit) $ -- for now the limit will be 1, @@ -142,7 +150,7 @@ processPtxsToResubmit pm txpConfig 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 txpConfig db submitTx toResubmit + resubmitPtxsDuringSlot coreConfig txpConfig db submitTx toResubmit where fmt sl = "Transactions to resubmit on current slot: "%secureListF sl listJson evalPtxsPerSlotLimit = do @@ -158,44 +166,47 @@ processPtxsToResubmit pm txpConfig db submitTx _curSlot ptxs = do -- if needed. processPtxs :: MonadPendings ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> WalletDB -> (TxAux -> m Bool) -> SlotId -> [PendingTx] -> m () -processPtxs pm txpConfig db submitTx curSlot ptxs = do +processPtxs coreConfig txpConfig db submitTx curSlot ptxs = do mapM_ (processPtxInNewestBlocks db) ptxs if walletTxCreationDisabled then logDebug "Transaction resubmission is disabled" - else processPtxsToResubmit pm txpConfig db submitTx curSlot ptxs + else processPtxsToResubmit coreConfig txpConfig db submitTx curSlot ptxs processPtxsOnSlot :: MonadPendings ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> WalletDB -> (TxAux -> m Bool) -> SlotId -> m () -processPtxsOnSlot pm txpConfig db submitTx curSlot = do +processPtxsOnSlot coreConfig txpConfig db submitTx curSlot = do ws <- getWalletSnapshot db let ptxs = getPendingTxs ws let sortedPtxs = getOldestFirst $ sortPtxsChrono ptxs - processPtxs pm txpConfig db submitTx curSlot sortedPtxs + processPtxs coreConfig txpConfig db submitTx curSlot sortedPtxs -- | On each slot this takes several pending transactions and resubmits them if -- needed and possible. startPendingTxsResubmitter :: MonadPendings ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> WalletDB -> (TxAux -> m Bool) -> m () -startPendingTxsResubmitter pm txpConfig db submitTx = - setLogger $ onNewSlot onsp (processPtxsOnSlot pm txpConfig db submitTx) +startPendingTxsResubmitter coreConfig txpConfig db submitTx = + setLogger $ onNewSlot + (configEpochSlots coreConfig) + onsp + (processPtxsOnSlot coreConfig txpConfig 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 00137c13052..cc75a729cba 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Handlers.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Handlers.hs @@ -21,8 +21,8 @@ import Servant.Swagger.UI (swaggerSchemaUIServer) import Pos.Chain.Txp (TxpConfiguration) import Pos.Chain.Update (curSoftwareVersion) +import Pos.Core as Core (Config (..)) import Pos.Core.Txp (TxAux) -import Pos.Crypto (ProtocolMagic) import Pos.Util.CompileInfo (HasCompileInfo) import Pos.Wallet.WalletMode (blockchainSlotDuration) @@ -39,14 +39,16 @@ servantHandlersWithSwagger :: ( MonadFullWalletWebMode ctx m , HasCompileInfo ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> TVar NtpStatus -> (TxAux -> m Bool) -> (forall x. m x -> Handler x) -> Server A.WalletSwaggerApi -servantHandlersWithSwagger pm txpConfig ntpStatus submitTx nat = - hoistServer A.walletApi nat (servantHandlers pm txpConfig ntpStatus submitTx) +servantHandlersWithSwagger coreConfig txpConfig ntpStatus submitTx nat = + hoistServer A.walletApi + nat + (servantHandlers coreConfig txpConfig ntpStatus submitTx) :<|> swaggerSchemaUIServer swaggerSpecForWalletApi @@ -58,20 +60,20 @@ servantHandlers :: ( MonadFullWalletWebMode ctx m , HasCompileInfo ) - => ProtocolMagic + => Core.Config -> TxpConfiguration -> TVar NtpStatus -> (TxAux -> m Bool) -> ServerT A.WalletApi m -servantHandlers pm txpConfig ntpStatus submitTx = toServant' A.WalletApiRecord +servantHandlers coreConfig txpConfig ntpStatus submitTx = toServant' A.WalletApiRecord { _test = testHandlers , _wallets = walletsHandlers , _accounts = accountsHandlers , _addresses = addressesHandlers , _profile = profileHandlers - , _txs = txsHandlers pm txpConfig submitTx + , _txs = txsHandlers coreConfig txpConfig submitTx , _update = updateHandlers - , _redemptions = redemptionsHandlers pm txpConfig submitTx + , _redemptions = redemptionsHandlers coreConfig txpConfig submitTx , _reporting = reportingHandlers , _settings = settingsHandlers ntpStatus , _backup = backupHandlers @@ -122,15 +124,16 @@ profileHandlers = toServant' A.WProfileApiRecord txsHandlers :: MonadFullWalletWebMode ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> m Bool) -> ServerT A.WTxsApi m -txsHandlers pm txpConfig submitTx = toServant' A.WTxsApiRecord - { _newPayment = M.newPayment pm txpConfig submitTx - , _newPaymentBatch = M.newPaymentBatch pm txpConfig submitTx - , _txFee = M.getTxFee pm - , _resetFailedPtxs = M.resetAllFailedPtxs +txsHandlers coreConfig txpConfig submitTx = toServant' A.WTxsApiRecord + { _newPayment = M.newPayment coreConfig txpConfig submitTx + , _newPaymentBatch = M.newPaymentBatch coreConfig txpConfig submitTx + , _txFee = M.getTxFee coreConfig + , _resetFailedPtxs = M.resetAllFailedPtxs $ + configProtocolConstants coreConfig , _cancelApplyingPtxs = M.cancelAllApplyingPtxs , _cancelSpecificApplyingPtx = M.cancelOneApplyingPtx , _getHistory = M.getHistoryLimited @@ -146,13 +149,13 @@ updateHandlers = toServant' A.WUpdateApiRecord redemptionsHandlers :: MonadFullWalletWebMode ctx m - => ProtocolMagic + => Core.Config -> TxpConfiguration -> (TxAux -> m Bool) -> ServerT A.WRedemptionsApi m -redemptionsHandlers pm txpConfig submitTx = toServant' A.WRedemptionsApiRecord - { _redeemADA = M.redeemAda pm txpConfig submitTx - , _redeemADAPaperVend = M.redeemAdaPaperVend pm txpConfig submitTx +redemptionsHandlers coreConfig txpConfig submitTx = toServant' A.WRedemptionsApiRecord + { _redeemADA = M.redeemAda coreConfig txpConfig submitTx + , _redeemADAPaperVend = M.redeemAdaPaperVend coreConfig txpConfig 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 9496c481e0d..2039a42bf28 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Launcher.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Launcher.hs @@ -30,8 +30,8 @@ import Ntp.Client (NtpStatus) import Pos.Chain.Txp (TxpConfiguration) import Pos.Client.Txp.Network (sendTxOuts) import Pos.Communication (OutSpecs) +import Pos.Core as Core (Config) import Pos.Core.NetworkAddress (NetworkAddress) -import Pos.Crypto (ProtocolMagic) import Pos.Infra.Diffusion.Types (Diffusion (sendTx)) import Pos.Util (bracketWithLogging) import Pos.Util.CompileInfo (HasCompileInfo) @@ -81,17 +81,17 @@ walletApplication serv = do upgradeApplicationWS wsConn . serve swaggerWalletApi <$> serv walletServer - :: forall ctx m. - ( MonadFullWalletWebMode ctx m, HasCompileInfo ) - => ProtocolMagic + :: forall ctx m + . (MonadFullWalletWebMode ctx m, HasCompileInfo) + => Core.Config -> TxpConfiguration -> Diffusion m -> TVar NtpStatus - -> (forall x. m x -> Handler x) + -> (forall x . m x -> Handler x) -> m (Server WalletSwaggerApi) -walletServer pm txpConfig diffusion ntpStatus nat = do +walletServer coreConfig txpConfig diffusion ntpStatus nat = do mapM_ (findKey >=> syncWallet . keyToWalletDecrCredentials) =<< myRootAddresses - return $ servantHandlersWithSwagger pm txpConfig ntpStatus submitTx nat + return $ servantHandlersWithSwagger coreConfig txpConfig 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 85a0b7bc324..8c023bb9aed 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Runner.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Runner.hs @@ -29,7 +29,6 @@ import Pos.Chain.Txp (TxpConfiguration) import Pos.Core as Core (Config (..), configGeneratedSecretsThrow) import Pos.Core.Genesis (gsPoorSecrets) import Pos.Core.NetworkAddress (NetworkAddress) -import Pos.Crypto (ProtocolMagic) import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion) import Pos.Infra.Shutdown.Class (HasShutdownContext (shutdownContext)) import Pos.Launcher.Configuration (HasConfigurations) @@ -52,11 +51,9 @@ import Pos.Web (TlsParams) -- | 'WalletWebMode' runner. runWRealMode - :: forall a . - ( HasConfigurations - , HasCompileInfo - ) - => ProtocolMagic + :: forall a + . (HasConfigurations, HasCompileInfo) + => Core.Config -> TxpConfiguration -> WalletDB -> ConnectionsVar @@ -64,8 +61,8 @@ runWRealMode -> NodeResources WalletMempoolExt -> (Diffusion WalletWebMode -> WalletWebMode a) -> IO a -runWRealMode pm txpConfig db conn syncRequests res action = - runRealMode pm txpConfig res $ \diffusion -> +runWRealMode coreConfig txpConfig db conn syncRequests res action = + runRealMode coreConfig txpConfig res $ \diffusion -> walletWebModeToRealMode db conn syncRequests $ action (hoistDiffusion realModeToWalletWebMode (walletWebModeToRealMode db conn syncRequests) diffusion) @@ -98,7 +95,7 @@ walletServeWebFull coreConfig txpConfig diffusion ntpStatus debug address mTlsPa wwmc <- walletWebModeContext walletApplication $ walletServer @WalletWebModeContext @WalletWebMode - (configProtocolMagic coreConfig) + coreConfig txpConfig diffusion ntpStatus diff --git a/wallet/src/Pos/Wallet/Web/State/State.hs b/wallet/src/Pos/Wallet/Web/State/State.hs index 27a76888e88..33c5440b559 100644 --- a/wallet/src/Pos/Wallet/Web/State/State.hs +++ b/wallet/src/Pos/Wallet/Web/State/State.hs @@ -101,8 +101,7 @@ import qualified Data.Map as Map import Pos.Chain.Block (HeaderHash) import Pos.Chain.Txp (TxId, Utxo, UtxoModifier) import Pos.Client.Txp.History (TxHistoryEntry) -import Pos.Core (Address, ChainDifficulty, HasProtocolConstants, - SlotId, protocolConstants) +import Pos.Core (Address, ChainDifficulty, ProtocolConstants, SlotId) import Pos.Util.Servant (encodeCType) import Pos.Util.Util (HasLens', lensOf) import Pos.Wallet.Web.ClientTypes (AccountId, CAccountMeta, CId, @@ -496,14 +495,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 @@ -516,19 +516,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 @@ -555,8 +554,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 @@ -567,11 +567,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 583b3cf4975..8b05c26af66 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs @@ -22,7 +22,7 @@ import Pos.Chain.Block (BlockHeader (..), Blund, HeaderHash, blockHeader, getBlockHeader, headerSlotL, mainBlockTxPayload, prevBlockL, undoTx) import Pos.Chain.Txp (flattenTxPayload) -import Pos.Core (Timestamp, difficultyL) +import Pos.Core (ProtocolConstants, Timestamp, difficultyL) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Txp (TxAux (..), TxUndo) import Pos.DB.BatchOp (SomeBatchOp) @@ -123,16 +123,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 @@ -161,7 +163,7 @@ onRollbackBlocksWebWallet blunds = setLogger . reportTimeouts "rollback" $ do let rollbackBlockWith trackingOperation = do let dbUsed = WS.getCustomAddresses ws WS.UsedAddr mapModifier = trackingRollbackTxs credentials 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 bd70d5419ec..a33809e0ac7 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs @@ -61,8 +61,8 @@ import Pos.Chain.Txp (UndoMap, flattenTxPayload, topsortTxs, import Pos.Client.Txp.History (TxHistoryEntry (..), txHistoryListToMap) import Pos.Core (Address, BlockCount (..), ChainDifficulty (..), - HasDifficulty (..), HasProtocolConstants, Timestamp (..), - blkSecurityParam, genesisHash, timestampToPosix) + HasDifficulty (..), ProtocolConstants, Timestamp (..), + genesisHash, pcEpochSlots, timestampToPosix) import Pos.Core.Chrono (getNewestFirst) import Pos.Core.Txp (TxAux (..), TxId, TxUndo) import Pos.Crypto (WithHash (..), shortHashF, withHash) @@ -112,14 +112,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 @@ -227,9 +229,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 @@ -323,14 +326,14 @@ 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) + (k + 1) (headerHash gstateTipH) logInfo $ sformat ( "Wallet's tip is far from GState tip. Syncing with the " @@ -770,27 +773,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 3f24b063de9..8150f7d7db6 100644 --- a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs @@ -29,6 +29,7 @@ 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, @@ -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/PaymentSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs index 00378785ec4..153623d3b5e 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs @@ -47,12 +47,11 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, getAccountAddrsOrThrow) import Pos.Util.Servant (encodeCType) import Test.Pos.Configuration (withDefConfigurations) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Core.Dummy (dummyConfig) 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) @@ -124,7 +123,7 @@ newPaymentFixture = do rejectPaymentIfRestoringSpec :: HasConfigurations => TxpConfiguration -> Spec rejectPaymentIfRestoringSpec txpConfig = walletPropertySpec "should fail with 403" $ do PaymentFixture{..} <- newPaymentFixture - res <- lift $ try (newPaymentBatch dummyProtocolMagic txpConfig submitTxTestMode pswd batch) + res <- lift $ try (newPaymentBatch dummyConfig txpConfig submitTxTestMode pswd batch) liftIO $ shouldBe res (Left (err403 { errReasonPhrase = "Transaction creation is disabled when the wallet is restoring." })) -- | Test one single, successful payment. @@ -137,7 +136,7 @@ oneNewPaymentBatchSpec txpConfig = walletPropertySpec oneNewPaymentBatchDesc $ d randomSyncTip <- liftIO $ generate arbitrary WS.setWalletSyncTip db walId randomSyncTip - void $ lift $ newPaymentBatch dummyProtocolMagic txpConfig submitTxTestMode pswd batch + void $ lift $ newPaymentBatch dummyConfig txpConfig 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 e21a5aa943d..c4bb467eee2 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Mode.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Mode.hs @@ -120,7 +120,7 @@ import Test.Pos.Block.Logic.Mode (BlockTestContext (..), getCurrentSlotBlockingTestDefault, getCurrentSlotInaccurateTestDefault, getCurrentSlotTestDefault, initBlockTestContext) -import Test.Pos.Core.Dummy (dummyGenesisSecretKeys) +import Test.Pos.Core.Dummy (dummyEpochSlots, dummyGenesisSecretKeys) ---------------------------------------------------------------------------- -- Parameters @@ -218,7 +218,7 @@ initWalletTestContext WalletTestParams {..} callback = wtcLastKnownHeader <- STM.newTVarIO Nothing wtcSentTxs <- STM.newTVarIO mempty wtcSyncQueue <- STM.newTQueueIO - wtcSlottingStateVar <- mkSimpleSlottingStateVar + wtcSlottingStateVar <- mkSimpleSlottingStateVar dummyEpochSlots pure WalletTestContext {..} callback wtc @@ -302,11 +302,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 HasUserPublic WalletTestContext where @@ -392,8 +391,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 getPublic = getPublicDefault diff --git a/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs index cf036a22f11..f4dbceac623 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 (Arbitrary (..), Property, choose, oneof, import Test.QuickCheck.Monadic (pick) import Pos.Chain.Txp (TxpConfiguration (..)) -import Pos.Core (Address, BlockCount (..), blkSecurityParam) +import Pos.Core (Address, BlockCount (..)) import Pos.Core.Chrono (nonEmptyOldestFirst, toNewestFirst) import Pos.Crypto (emptyPassphrase) import Pos.DB.Block (rollbackBlocks) @@ -42,7 +42,7 @@ import Pos.Wallet.Web.Tracking.Types (newSyncRequest) import Test.Pos.Block.Logic.Util (EnableTxPayload (..), InplaceDB (..)) import Test.Pos.Configuration (withDefConfigurations) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Core.Dummy (dummyConfig, dummyK) import Test.Pos.Util.QuickCheck.Property (assertProperty) import Test.Pos.Wallet.Arbitrary.Web.ClientTypes () import Test.Pos.Wallet.Web.Mode (walletPropertySpec) @@ -63,27 +63,25 @@ 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) secretKeys <- lift getSecretKeysPlain lift $ forM_ secretKeys $ \sk -> - syncWalletWithBlockchain . newSyncRequest . keyToWalletDecrCredentials $ KeyForRegular sk + syncWalletWithBlockchain dummyK . newSyncRequest . keyToWalletDecrCredentials $ KeyForRegular sk -- Testing starts here genesisWalletDB <- lift WS.askWalletSnapshot applyBlocksCnt1 <- pick $ choose (1, k `div` 2) applyBlocksCnt2 <- pick $ choose (1, k `div` 2) let txpConfig = TxpConfiguration 200 Set.empty - blunds1 <- wpGenBlocks dummyProtocolMagic - txpConfig + blunds1 <- wpGenBlocks txpConfig (Just $ BlockCount applyBlocksCnt1) (EnableTxPayload True) (InplaceDB True) after1ApplyDB <- lift WS.askWalletSnapshot - blunds2 <- wpGenBlocks dummyProtocolMagic - txpConfig + blunds2 <- wpGenBlocks txpConfig (Just $ BlockCount applyBlocksCnt2) (EnableTxPayload True) (InplaceDB True) @@ -91,9 +89,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 dummyConfig to1Rollback after1RollbackDB <- lift WS.askWalletSnapshot - lift $ rollbackBlocks dummyProtocolMagic to2Rollback + lift $ rollbackBlocks dummyConfig 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 9db9d566325..a29429a882b 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Util.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Util.hs @@ -46,7 +46,7 @@ import Pos.Core.Chrono (OldestFirst (..)) import Pos.Core.Common (IsBootstrapEraAddr (..), deriveLvl2KeyPair) import Pos.Core.Genesis (poorSecretToEncKey) import Pos.Core.Txp (TxIn, TxOut (..), TxOutAux (..)) -import Pos.Crypto (EncryptedSecretKey, PassPhrase, ProtocolMagic, +import Pos.Crypto (EncryptedSecretKey, PassPhrase, ShouldCheckPassphrase (..), emptyPassphrase, firstHardened) import Pos.Generator.Block (genBlocks) @@ -64,7 +64,7 @@ import Pos.Infra.Util.JsonLog.Events import Test.Pos.Block.Logic.Util (EnableTxPayload, InplaceDB, genBlockGenParams) import Test.Pos.Core.Arbitrary.Txp () -import Test.Pos.Core.Dummy (dummyGenesisSecretsPoor) +import Test.Pos.Core.Dummy (dummyConfig, dummyGenesisSecretsPoor) import Test.Pos.Util.QuickCheck.Property (assertProperty, maybeStopProperty) import Test.Pos.Wallet.Web.Mode (WalletProperty) @@ -76,17 +76,16 @@ import Test.Pos.Wallet.Web.Mode (WalletProperty) -- | Gen blocks in WalletProperty wpGenBlocks :: HasConfigurations - => ProtocolMagic - -> TxpConfiguration + => TxpConfiguration -> Maybe BlockCount -> EnableTxPayload -> InplaceDB -> WalletProperty (OldestFirst [] Blund) -wpGenBlocks pm txpConfig blkCnt enTxPayload inplaceDB = do - params <- genBlockGenParams pm blkCnt enTxPayload inplaceDB +wpGenBlocks txpConfig blkCnt enTxPayload inplaceDB = do + 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 txpConfig params maybeToList) g + blunds <- OldestFirst <$> evalRandT (genBlocks dummyConfig txpConfig params maybeToList) g case nonEmpty $ getOldestFirst blunds of Just nonEmptyBlunds -> do let tipBlockHeader = nonEmptyBlunds ^. _neLast . _1 . blockHeader @@ -97,12 +96,11 @@ wpGenBlocks pm txpConfig blkCnt enTxPayload inplaceDB = do wpGenBlock :: HasConfigurations - => ProtocolMagic - -> TxpConfiguration + => TxpConfiguration -> EnableTxPayload -> InplaceDB -> WalletProperty Blund -wpGenBlock pm txpConfig = fmap (Data.List.head . toList) ... wpGenBlocks pm txpConfig (Just 1) +wpGenBlock txpConfig = fmap (Data.List.head . toList) ... wpGenBlocks txpConfig (Just 1) ---------------------------------------------------------------------------- -- Wallet test helpers